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