warnings.pl

   1 #!/usr/bin/perl
   2
   3 $VERSION = '1.02_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 /* -*- buffer-read-only: t -*-
 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               NULL
 280 #define pWARN_ALL               (((STRLEN*)0)+1)    /* use warnings 'all' */
 281 #define pWARN_NONE              (((STRLEN*)0)+2)    /* no  warnings 'all' */
 282
 283 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
 284                                  (x) == pWARN_NONE)
 285
 286 /* if PL_warnhook is set to this value, then warnings die */
 287 #define PERL_WARNHOOK_FATAL     (&PL_sv_placeholder)
 288 EOM
 289
 290 my $offset = 0 ;
 291
 292 $index = $offset ;
 293 #@{ $list{"all"} } = walk ($tree) ;
 294 valueWalk ($tree) ;
 295 my $index = orderValues();
 296
 297 die <<EOM if $index > 255 ;
 298 Too many warnings categories -- max is 255
 299     rewrite packWARN* & unpackWARN* macros
 300 EOM
 301
 302 walk ($tree) ;
 303
 304 $index *= 2 ;
 305 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 306
 307 my $k ;
 308 my $last_ver = 0;
 309 foreach $k (sort { $a <=> $b } keys %ValueToName) {
 310     my ($name, $version) = @{ $ValueToName{$k} };
 311     print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
 312         if $last_ver != $version ;
 313     print WARN tab(5, "#define WARN_$name"), "$k\n" ;
 314     $last_ver = $version ;
 315 }
 316 print WARN "\n" ;
 317
 318 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
 319 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 320 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 321 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\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((U8 *)(c + 1), 2*(x)))
 329 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
 330
 331 #define DUP_WARNINGS(p)         \
 332     (specialWARN(p) ? (STRLEN*)(p)      \
 333     : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
 334                                              char))
 335
 336 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
 337 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
 338 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
 339 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
 340
 341 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
 342 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
 343 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
 344 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
 345
 346 #define packWARN(a)             (a                                      )
 347 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
 348 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
 349 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
 350
 351 #define unpackWARN1(x)          ((x)        & 0xFF)
 352 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
 353 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
 354 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
 355
 356 #define ckDEAD(x)                                                       \
 357            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 358             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
 359               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
 360               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
 361               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
 362               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
 363
 364 /* end of file warnings.h */
 365 /* ex: set ro: */
 366 EOM
 367
 368 close WARN ;
 369
 370 while (<DATA>) {
 371     last if /^KEYWORDS$/ ;
 372     print PM $_ ;
 373 }
 374
 375 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
 376
 377 $last_ver = 0;
 378 print PM "our %Offsets = (\n" ;
 379 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
 380     my ($name, $version) = @{ $ValueToName{$k} };
 381     $name = lc $name;
 382     $k *= 2 ;
 383     if ( $last_ver != $version ) {
 384         print PM "\n";
 385         print PM tab(4, "    # Warnings Categories added in Perl $version");
 386         print PM "\n\n";
 387     }
 388     print PM tab(4, "    '$name'"), "=> $k,\n" ;
 389     $last_ver = $version;
 390 }
 391
 392 print PM "  );\n\n" ;
 393
 394 print PM "our %Bits = (\n" ;
 395 foreach $k (sort keys  %list) {
 396
 397     my $v = $list{$k} ;
 398     my @list = sort { $a <=> $b } @$v ;
 399
 400     print PM tab(4, "    '$k'"), '=> "',
 401                 # mkHex($warn_size, @list),
 402                 mkHex($warn_size, map $_ * 2 , @list),
 403                 '", # [', mkRange(@list), "]\n" ;
 404 }
 405
 406 print PM "  );\n\n" ;
 407
 408 print PM "our %DeadBits = (\n" ;
 409 foreach $k (sort keys  %list) {
 410
 411     my $v = $list{$k} ;
 412     my @list = sort { $a <=> $b } @$v ;
 413
 414     print PM tab(4, "    '$k'"), '=> "',
 415                 # mkHex($warn_size, @list),
 416                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 417                 '", # [', mkRange(@list), "]\n" ;
 418 }
 419
 420 print PM "  );\n\n" ;
 421 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
 422 print PM '$LAST_BIT = ' . "$index ;\n" ;
 423 print PM '$BYTES    = ' . "$warn_size ;\n" ;
 424 while (<DATA>) {
 425     print PM $_ ;
 426 }
 427
 428 print PM "# ex: set ro:\n";
 429 close PM ;
 430
 431 __END__
 432 # -*- buffer-read-only: t -*-
 433 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 434 # This file was created by warnings.pl
 435 # Any changes made here will be lost.
 436 #
 437
 438 package warnings;
 439
 440 our $VERSION = '1.06';
 441
 442 # Verify that we're called correctly so that warnings will work.
 443 # see also strict.pm.
 444 unless ( __FILE__ =~ /(^|[\/\\])\Q@{[__PACKAGE__]}\E\.pm$/ ) {
 445     my (undef, $f, $l) = caller;
 446     die("Incorrect use of pragma '@{[__PACKAGE__,]}' at $f line $l.\n");
 447 }
 448
 449 =head1 NAME
 450
 451 warnings - Perl pragma to control optional warnings
 452
 453 =head1 SYNOPSIS
 454
 455     use warnings;
 456     no warnings;
 457
 458     use warnings "all";
 459     no warnings "all";
 460
 461     use warnings::register;
 462     if (warnings::enabled()) {
 463         warnings::warn("some warning");
 464     }
 465
 466     if (warnings::enabled("void")) {
 467         warnings::warn("void", "some warning");
 468     }
 469
 470     if (warnings::enabled($object)) {
 471         warnings::warn($object, "some warning");
 472     }
 473
 474     warnings::warnif("some warning");
 475     warnings::warnif("void", "some warning");
 476     warnings::warnif($object, "some warning");
 477
 478 =head1 DESCRIPTION
 479
 480 The C<warnings> pragma is a replacement for the command line flag C<-w>,
 481 but the pragma is limited to the enclosing block, while the flag is global.
 482 See L<perllexwarn> for more information.
 483
 484 If no import list is supplied, all possible warnings are either enabled
 485 or disabled.
 486
 487 A number of functions are provided to assist module authors.
 488
 489 =over 4
 490
 491 =item use warnings::register
 492
 493 Creates a new warnings category with the same name as the package where
 494 the call to the pragma is used.
 495
 496 =item warnings::enabled()
 497
 498 Use the warnings category with the same name as the current package.
 499
 500 Return TRUE if that warnings category is enabled in the calling module.
 501 Otherwise returns FALSE.
 502
 503 =item warnings::enabled($category)
 504
 505 Return TRUE if the warnings category, C<$category>, is enabled in the
 506 calling module.
 507 Otherwise returns FALSE.
 508
 509 =item warnings::enabled($object)
 510
 511 Use the name of the class for the object reference, C<$object>, as the
 512 warnings category.
 513
 514 Return TRUE if that warnings category is enabled in the first scope
 515 where the object is used.
 516 Otherwise returns FALSE.
 517
 518 =item warnings::warn($message)
 519
 520 Print C<$message> to STDERR.
 521
 522 Use the warnings category with the same name as the current package.
 523
 524 If that warnings category has been set to "FATAL" in the calling module
 525 then die. Otherwise return.
 526
 527 =item warnings::warn($category, $message)
 528
 529 Print C<$message> to STDERR.
 530
 531 If the warnings category, C<$category>, has been set to "FATAL" in the
 532 calling module then die. Otherwise return.
 533
 534 =item warnings::warn($object, $message)
 535
 536 Print C<$message> to STDERR.
 537
 538 Use the name of the class for the object reference, C<$object>, as the
 539 warnings category.
 540
 541 If that warnings category has been set to "FATAL" in the scope where C<$object>
 542 is first used then die. Otherwise return.
 543
 544
 545 =item warnings::warnif($message)
 546
 547 Equivalent to:
 548
 549     if (warnings::enabled())
 550       { warnings::warn($message) }
 551
 552 =item warnings::warnif($category, $message)
 553
 554 Equivalent to:
 555
 556     if (warnings::enabled($category))
 557       { warnings::warn($category, $message) }
 558
 559 =item warnings::warnif($object, $message)
 560
 561 Equivalent to:
 562
 563     if (warnings::enabled($object))
 564       { warnings::warn($object, $message) }
 565
 566 =back
 567
 568 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 569
 570 =cut
 571
 572 KEYWORDS
 573
 574 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 575
 576 sub Croaker
 577 {
 578     require Carp::Heavy; # this initializes %CarpInternal
 579     local $Carp::CarpInternal{'warnings'};
 580     delete $Carp::CarpInternal{'warnings'};
 581     Carp::croak(@_);
 582 }
 583
 584 sub bits
 585 {
 586     # called from B::Deparse.pm
 587
 588     push @_, 'all' unless @_;
 589
 590     my $mask;
 591     my $catmask ;
 592     my $fatal = 0 ;
 593     my $no_fatal = 0 ;
 594
 595     foreach my $word ( @_ ) {
 596         if ($word eq 'FATAL') {
 597             $fatal = 1;
 598             $no_fatal = 0;
 599         }
 600         elsif ($word eq 'NONFATAL') {
 601             $fatal = 0;
 602             $no_fatal = 1;
 603         }
 604         elsif ($catmask = $Bits{$word}) {
 605             $mask |= $catmask ;
 606             $mask |= $DeadBits{$word} if $fatal ;
 607             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 608         }
 609         else
 610           { Croaker("Unknown warnings category '$word'")}
 611     }
 612
 613     return $mask ;
 614 }
 615
 616 sub import
 617 {
 618     shift;
 619
 620     my $catmask ;
 621     my $fatal = 0 ;
 622     my $no_fatal = 0 ;
 623
 624     my $mask = ${^WARNING_BITS} ;
 625
 626     if (vec($mask, $Offsets{'all'}, 1)) {
 627         $mask |= $Bits{'all'} ;
 628         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 629     }
 630
 631     push @_, 'all' unless @_;
 632
 633     foreach my $word ( @_ ) {
 634         if ($word eq 'FATAL') {
 635             $fatal = 1;
 636             $no_fatal = 0;
 637         }
 638         elsif ($word eq 'NONFATAL') {
 639             $fatal = 0;
 640             $no_fatal = 1;
 641         }
 642         elsif ($catmask = $Bits{$word}) {
 643             $mask |= $catmask ;
 644             $mask |= $DeadBits{$word} if $fatal ;
 645             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 646         }
 647         else
 648           { Croaker("Unknown warnings category '$word'")}
 649     }
 650
 651     ${^WARNING_BITS} = $mask ;
 652 }
 653
 654 sub unimport
 655 {
 656     shift;
 657
 658     my $catmask ;
 659     my $mask = ${^WARNING_BITS} ;
 660
 661     if (vec($mask, $Offsets{'all'}, 1)) {
 662         $mask |= $Bits{'all'} ;
 663         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 664     }
 665
 666     push @_, 'all' unless @_;
 667
 668     foreach my $word ( @_ ) {
 669         if ($word eq 'FATAL') {
 670             next;
 671         }
 672         elsif ($catmask = $Bits{$word}) {
 673             $mask &= ~($catmask | $DeadBits{$word} | $All);
 674         }
 675         else
 676           { Croaker("Unknown warnings category '$word'")}
 677     }
 678
 679     ${^WARNING_BITS} = $mask ;
 680 }
 681
 682 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 683
 684 sub __chk
 685 {
 686     my $category ;
 687     my $offset ;
 688     my $isobj = 0 ;
 689
 690     if (@_) {
 691         # check the category supplied.
 692         $category = shift ;
 693         if (my $type = ref $category) {
 694             Croaker("not an object")
 695                 if exists $builtin_type{$type};
 696             $category = $type;
 697             $isobj = 1 ;
 698         }
 699         $offset = $Offsets{$category};
 700         Croaker("Unknown warnings category '$category'")
 701             unless defined $offset;
 702     }
 703     else {
 704         $category = (caller(1))[0] ;
 705         $offset = $Offsets{$category};
 706         Croaker("package '$category' not registered for warnings")
 707             unless defined $offset ;
 708     }
 709
 710     my $this_pkg = (caller(1))[0] ;
 711     my $i = 2 ;
 712     my $pkg ;
 713
 714     if ($isobj) {
 715         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 716             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 717         }
 718         $i -= 2 ;
 719     }
 720     else {
 721         $i = _error_loc(); # see where Carp will allocate the error
 722     }
 723
 724     my $callers_bitmask = (caller($i))[9] ;
 725     return ($callers_bitmask, $offset, $i) ;
 726 }
 727
 728 sub _error_loc {
 729     require Carp::Heavy;
 730     goto &Carp::short_error_loc; # don't introduce another stack frame
 731 }
 732
 733 sub enabled
 734 {
 735     Croaker("Usage: warnings::enabled([category])")
 736         unless @_ == 1 || @_ == 0 ;
 737
 738     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 739
 740     return 0 unless defined $callers_bitmask ;
 741     return vec($callers_bitmask, $offset, 1) ||
 742            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 743 }
 744
 745
 746 sub warn
 747 {
 748     Croaker("Usage: warnings::warn([category,] 'message')")
 749         unless @_ == 2 || @_ == 1 ;
 750
 751     my $message = pop ;
 752     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 753     require Carp;
 754     Carp::croak($message)
 755         if vec($callers_bitmask, $offset+1, 1) ||
 756            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 757     Carp::carp($message) ;
 758 }
 759
 760 sub warnif
 761 {
 762     Croaker("Usage: warnings::warnif([category,] 'message')")
 763         unless @_ == 2 || @_ == 1 ;
 764
 765     my $message = pop ;
 766     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 767
 768     return
 769         unless defined $callers_bitmask &&
 770                 (vec($callers_bitmask, $offset, 1) ||
 771                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 772
 773     require Carp;
 774     Carp::croak($message)
 775         if vec($callers_bitmask, $offset+1, 1) ||
 776            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 777
 778     Carp::carp($message) ;
 779 }
 780
 781 1;