warnings.pl

   1 #!/usr/bin/perl
   2
   3 $VERSION = '1.02_01';
   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          #'default'     => [ 5.008, DEFAULT_ON ],
  66         }],
  67 } ;
  68
  69 ###########################################################################
  70 sub tab {
  71     my($l, $t) = @_;
  72     $t .= "\t" x ($l - (length($t) + 1) / 8);
  73     $t;
  74 }
  75
  76 ###########################################################################
  77
  78 my %list ;
  79 my %Value ;
  80 my %ValueToName ;
  81 my %NameToValue ;
  82 my $index ;
  83
  84 my %v_list = () ;
  85
  86 sub valueWalk
  87 {
  88     my $tre = shift ;
  89     my @list = () ;
  90     my ($k, $v) ;
  91
  92     foreach $k (sort keys %$tre) {
  93         $v = $tre->{$k};
  94         die "duplicate key $k\n" if defined $list{$k} ;
  95         die "Value associated with key '$k' is not an ARRAY reference"
  96             if !ref $v || ref $v ne 'ARRAY' ;
  97
  98         my ($ver, $rest) = @{ $v } ;
  99         push @{ $v_list{$ver} }, $k;
 100
 101         if (ref $rest)
 102           { valueWalk ($rest) }
 103
 104     }
 105
 106 }
 107
 108 sub orderValues
 109 {
 110     my $index = 0;
 111     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
 112         foreach my $name (@{ $v_list{$ver} } ) {
 113             $ValueToName{ $index } = [ uc $name, $ver ] ;
 114             $NameToValue{ uc $name } = $index ++ ;
 115         }
 116     }
 117
 118     return $index ;
 119 }
 120
 121 ###########################################################################
 122
 123 sub walk
 124 {
 125     my $tre = shift ;
 126     my @list = () ;
 127     my ($k, $v) ;
 128
 129     foreach $k (sort keys %$tre) {
 130         $v = $tre->{$k};
 131         die "duplicate key $k\n" if defined $list{$k} ;
 132         #$Value{$index} = uc $k ;
 133         die "Can't find key '$k'"
 134             if ! defined $NameToValue{uc $k} ;
 135         push @{ $list{$k} }, $NameToValue{uc $k} ;
 136         die "Value associated with key '$k' is not an ARRAY reference"
 137             if !ref $v || ref $v ne 'ARRAY' ;
 138
 139         my ($ver, $rest) = @{ $v } ;
 140         if (ref $rest)
 141           { push (@{ $list{$k} }, walk ($rest)) }
 142
 143         push @list, @{ $list{$k} } ;
 144     }
 145
 146    return @list ;
 147 }
 148
 149 ###########################################################################
 150
 151 sub mkRange
 152 {
 153     my @a = @_ ;
 154     my @out = @a ;
 155     my $i ;
 156
 157
 158     for ($i = 1 ; $i < @a; ++ $i) {
 159         $out[$i] = ".."
 160           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
 161     }
 162
 163     my $out = join(",",@out);
 164
 165     $out =~ s/,(\.\.,)+/../g ;
 166     return $out;
 167 }
 168
 169 ###########################################################################
 170 sub printTree
 171 {
 172     my $tre = shift ;
 173     my $prefix = shift ;
 174     my ($k, $v) ;
 175
 176     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
 177     my @keys = sort keys %$tre ;
 178
 179     while ($k = shift @keys) {
 180         $v = $tre->{$k};
 181         die "Value associated with key '$k' is not an ARRAY reference"
 182             if !ref $v || ref $v ne 'ARRAY' ;
 183
 184         my $offset ;
 185         if ($tre ne $tree) {
 186             print $prefix . "|\n" ;
 187             print $prefix . "+- $k" ;
 188             $offset = ' ' x ($max + 4) ;
 189         }
 190         else {
 191             print $prefix . "$k" ;
 192             $offset = ' ' x ($max + 1) ;
 193         }
 194
 195         my ($ver, $rest) = @{ $v } ;
 196         if (ref $rest)
 197         {
 198             my $bar = @keys ? "|" : " ";
 199             print " -" . "-" x ($max - length $k ) . "+\n" ;
 200             printTree ($rest, $prefix . $bar . $offset )
 201         }
 202         else
 203           { print "\n" }
 204     }
 205
 206 }
 207
 208 ###########################################################################
 209
 210 sub mkHexOct
 211 {
 212     my ($f, $max, @a) = @_ ;
 213     my $mask = "\x00" x $max ;
 214     my $string = "" ;
 215
 216     foreach (@a) {
 217         vec($mask, $_, 1) = 1 ;
 218     }
 219
 220     foreach (unpack("C*", $mask)) {
 221         if ($f eq 'x') {
 222             $string .= '\x' . sprintf("%2.2x", $_)
 223         }
 224         else {
 225             $string .= '\\' . sprintf("%o", $_)
 226         }
 227     }
 228     return $string ;
 229 }
 230
 231 sub mkHex
 232 {
 233     my($max, @a) = @_;
 234     return mkHexOct("x", $max, @a);
 235 }
 236
 237 sub mkOct
 238 {
 239     my($max, @a) = @_;
 240     return mkHexOct("o", $max, @a);
 241 }
 242
 243 ###########################################################################
 244
 245 if (@ARGV && $ARGV[0] eq "tree")
 246 {
 247     printTree($tree, "    ") ;
 248     exit ;
 249 }
 250
 251 unlink "warnings.h";
 252 unlink "lib/warnings.pm";
 253 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
 254 binmode WARN;
 255 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
 256 binmode PM;
 257
 258 print WARN <<'EOM' ;
 259 /* -*- buffer-read-only: t -*-
 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_const(c), 2*(x)))
 328 #define isWARNf_on(c,x) (IsSet(SvPVX_const(c), 2*(x)+1))
 329
 330 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
 331 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
 332 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
 333 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
 334
 335 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
 336 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
 337 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
 338 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
 339
 340 #define packWARN(a)             (a                                      )
 341 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
 342 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
 343 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
 344
 345 #define unpackWARN1(x)          ((x)        & 0xFF)
 346 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
 347 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
 348 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
 349
 350 #define ckDEAD(x)                                                       \
 351            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 352             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
 353               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
 354               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
 355               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
 356               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
 357
 358 /* end of file warnings.h */
 359 /* ex: set ro: */
 360 EOM
 361
 362 close WARN ;
 363
 364 while (<DATA>) {
 365     last if /^KEYWORDS$/ ;
 366     print PM $_ ;
 367 }
 368
 369 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
 370
 371 $last_ver = 0;
 372 print PM "our %Offsets = (\n" ;
 373 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
 374     my ($name, $version) = @{ $ValueToName{$k} };
 375     $name = lc $name;
 376     $k *= 2 ;
 377     if ( $last_ver != $version ) {
 378         print PM "\n";
 379         print PM tab(4, "    # Warnings Categories added in Perl $version");
 380         print PM "\n\n";
 381     }
 382     print PM tab(4, "    '$name'"), "=> $k,\n" ;
 383     $last_ver = $version;
 384 }
 385
 386 print PM "  );\n\n" ;
 387
 388 print PM "our %Bits = (\n" ;
 389 foreach $k (sort keys  %list) {
 390
 391     my $v = $list{$k} ;
 392     my @list = sort { $a <=> $b } @$v ;
 393
 394     print PM tab(4, "    '$k'"), '=> "',
 395                 # mkHex($warn_size, @list),
 396                 mkHex($warn_size, map $_ * 2 , @list),
 397                 '", # [', mkRange(@list), "]\n" ;
 398 }
 399
 400 print PM "  );\n\n" ;
 401
 402 print PM "our %DeadBits = (\n" ;
 403 foreach $k (sort keys  %list) {
 404
 405     my $v = $list{$k} ;
 406     my @list = sort { $a <=> $b } @$v ;
 407
 408     print PM tab(4, "    '$k'"), '=> "',
 409                 # mkHex($warn_size, @list),
 410                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 411                 '", # [', mkRange(@list), "]\n" ;
 412 }
 413
 414 print PM "  );\n\n" ;
 415 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
 416 print PM '$LAST_BIT = ' . "$index ;\n" ;
 417 print PM '$BYTES    = ' . "$warn_size ;\n" ;
 418 while (<DATA>) {
 419     print PM $_ ;
 420 }
 421
 422 print PM "# ex: set ro:\n";
 423 close PM ;
 424
 425 __END__
 426 # -*- buffer-read-only: t -*-
 427 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 428 # This file was created by warnings.pl
 429 # Any changes made here will be lost.
 430 #
 431
 432 package warnings;
 433
 434 our $VERSION = '1.03';
 435
 436 =head1 NAME
 437
 438 warnings - Perl pragma to control optional warnings
 439
 440 =head1 SYNOPSIS
 441
 442     use warnings;
 443     no warnings;
 444
 445     use warnings "all";
 446     no warnings "all";
 447
 448     use warnings::register;
 449     if (warnings::enabled()) {
 450         warnings::warn("some warning");
 451     }
 452
 453     if (warnings::enabled("void")) {
 454         warnings::warn("void", "some warning");
 455     }
 456
 457     if (warnings::enabled($object)) {
 458         warnings::warn($object, "some warning");
 459     }
 460
 461     warnings::warnif("some warning");
 462     warnings::warnif("void", "some warning");
 463     warnings::warnif($object, "some warning");
 464
 465 =head1 DESCRIPTION
 466
 467 The C<warnings> pragma is a replacement for the command line flag C<-w>,
 468 but the pragma is limited to the enclosing block, while the flag is global.
 469 See L<perllexwarn> for more information.
 470
 471 If no import list is supplied, all possible warnings are either enabled
 472 or disabled.
 473
 474 A number of functions are provided to assist module authors.
 475
 476 =over 4
 477
 478 =item use warnings::register
 479
 480 Creates a new warnings category with the same name as the package where
 481 the call to the pragma is used.
 482
 483 =item warnings::enabled()
 484
 485 Use the warnings category with the same name as the current package.
 486
 487 Return TRUE if that warnings category is enabled in the calling module.
 488 Otherwise returns FALSE.
 489
 490 =item warnings::enabled($category)
 491
 492 Return TRUE if the warnings category, C<$category>, is enabled in the
 493 calling module.
 494 Otherwise returns FALSE.
 495
 496 =item warnings::enabled($object)
 497
 498 Use the name of the class for the object reference, C<$object>, as the
 499 warnings category.
 500
 501 Return TRUE if that warnings category is enabled in the first scope
 502 where the object is used.
 503 Otherwise returns FALSE.
 504
 505 =item warnings::warn($message)
 506
 507 Print C<$message> to STDERR.
 508
 509 Use the warnings category with the same name as the current package.
 510
 511 If that warnings category has been set to "FATAL" in the calling module
 512 then die. Otherwise return.
 513
 514 =item warnings::warn($category, $message)
 515
 516 Print C<$message> to STDERR.
 517
 518 If the warnings category, C<$category>, has been set to "FATAL" in the
 519 calling module then die. Otherwise return.
 520
 521 =item warnings::warn($object, $message)
 522
 523 Print C<$message> to STDERR.
 524
 525 Use the name of the class for the object reference, C<$object>, as the
 526 warnings category.
 527
 528 If that warnings category has been set to "FATAL" in the scope where C<$object>
 529 is first used then die. Otherwise return.
 530
 531
 532 =item warnings::warnif($message)
 533
 534 Equivalent to:
 535
 536     if (warnings::enabled())
 537       { warnings::warn($message) }
 538
 539 =item warnings::warnif($category, $message)
 540
 541 Equivalent to:
 542
 543     if (warnings::enabled($category))
 544       { warnings::warn($category, $message) }
 545
 546 =item warnings::warnif($object, $message)
 547
 548 Equivalent to:
 549
 550     if (warnings::enabled($object))
 551       { warnings::warn($object, $message) }
 552
 553 =back
 554
 555 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 556
 557 =cut
 558
 559 use Carp ();
 560
 561 KEYWORDS
 562
 563 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 564
 565 sub Croaker
 566 {
 567     delete $Carp::CarpInternal{'warnings'};
 568     Carp::croak(@_);
 569 }
 570
 571 sub bits
 572 {
 573     # called from B::Deparse.pm
 574
 575     push @_, 'all' unless @_;
 576
 577     my $mask;
 578     my $catmask ;
 579     my $fatal = 0 ;
 580     my $no_fatal = 0 ;
 581
 582     foreach my $word ( @_ ) {
 583         if ($word eq 'FATAL') {
 584             $fatal = 1;
 585             $no_fatal = 0;
 586         }
 587         elsif ($word eq 'NONFATAL') {
 588             $fatal = 0;
 589             $no_fatal = 1;
 590         }
 591         elsif ($catmask = $Bits{$word}) {
 592             $mask |= $catmask ;
 593             $mask |= $DeadBits{$word} if $fatal ;
 594             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 595         }
 596         else
 597           { Croaker("Unknown warnings category '$word'")}
 598     }
 599
 600     return $mask ;
 601 }
 602
 603 sub import
 604 {
 605     shift;
 606
 607     my $catmask ;
 608     my $fatal = 0 ;
 609     my $no_fatal = 0 ;
 610
 611     my $mask = ${^WARNING_BITS} ;
 612
 613     if (vec($mask, $Offsets{'all'}, 1)) {
 614         $mask |= $Bits{'all'} ;
 615         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 616     }
 617
 618     push @_, 'all' unless @_;
 619
 620     foreach my $word ( @_ ) {
 621         if ($word eq 'FATAL') {
 622             $fatal = 1;
 623             $no_fatal = 0;
 624         }
 625         elsif ($word eq 'NONFATAL') {
 626             $fatal = 0;
 627             $no_fatal = 1;
 628         }
 629         elsif ($catmask = $Bits{$word}) {
 630             $mask |= $catmask ;
 631             $mask |= $DeadBits{$word} if $fatal ;
 632             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 633         }
 634         else
 635           { Croaker("Unknown warnings category '$word'")}
 636     }
 637
 638     ${^WARNING_BITS} = $mask ;
 639 }
 640
 641 sub unimport
 642 {
 643     shift;
 644
 645     my $catmask ;
 646     my $mask = ${^WARNING_BITS} ;
 647
 648     if (vec($mask, $Offsets{'all'}, 1)) {
 649         $mask |= $Bits{'all'} ;
 650         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 651     }
 652
 653     push @_, 'all' unless @_;
 654
 655     foreach my $word ( @_ ) {
 656         if ($word eq 'FATAL') {
 657             next;
 658         }
 659         elsif ($catmask = $Bits{$word}) {
 660             $mask &= ~($catmask | $DeadBits{$word} | $All);
 661         }
 662         else
 663           { Croaker("Unknown warnings category '$word'")}
 664     }
 665
 666     ${^WARNING_BITS} = $mask ;
 667 }
 668
 669 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 670
 671 sub __chk
 672 {
 673     my $category ;
 674     my $offset ;
 675     my $isobj = 0 ;
 676
 677     if (@_) {
 678         # check the category supplied.
 679         $category = shift ;
 680         if (my $type = ref $category) {
 681             Croaker("not an object")
 682                 if exists $builtin_type{$type};
 683             $category = $type;
 684             $isobj = 1 ;
 685         }
 686         $offset = $Offsets{$category};
 687         Croaker("Unknown warnings category '$category'")
 688             unless defined $offset;
 689     }
 690     else {
 691         $category = (caller(1))[0] ;
 692         $offset = $Offsets{$category};
 693         Croaker("package '$category' not registered for warnings")
 694             unless defined $offset ;
 695     }
 696
 697     my $this_pkg = (caller(1))[0] ;
 698     my $i = 2 ;
 699     my $pkg ;
 700
 701     if ($isobj) {
 702         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 703             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 704         }
 705         $i -= 2 ;
 706     }
 707     else {
 708         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 709             last if $pkg ne $this_pkg ;
 710         }
 711         $i = 2
 712             if !$pkg || $pkg eq $this_pkg ;
 713     }
 714
 715     my $callers_bitmask = (caller($i))[9] ;
 716     return ($callers_bitmask, $offset, $i) ;
 717 }
 718
 719 sub enabled
 720 {
 721     Croaker("Usage: warnings::enabled([category])")
 722         unless @_ == 1 || @_ == 0 ;
 723
 724     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 725
 726     return 0 unless defined $callers_bitmask ;
 727     return vec($callers_bitmask, $offset, 1) ||
 728            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 729 }
 730
 731
 732 sub warn
 733 {
 734     Croaker("Usage: warnings::warn([category,] 'message')")
 735         unless @_ == 2 || @_ == 1 ;
 736
 737     my $message = pop ;
 738     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 739     Carp::croak($message)
 740         if vec($callers_bitmask, $offset+1, 1) ||
 741            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 742     Carp::carp($message) ;
 743 }
 744
 745 sub warnif
 746 {
 747     Croaker("Usage: warnings::warnif([category,] 'message')")
 748         unless @_ == 2 || @_ == 1 ;
 749
 750     my $message = pop ;
 751     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 752
 753     return
 754         unless defined $callers_bitmask &&
 755                 (vec($callers_bitmask, $offset, 1) ||
 756                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 757
 758     Carp::croak($message)
 759         if vec($callers_bitmask, $offset+1, 1) ||
 760            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 761
 762     Carp::carp($message) ;
 763 }
 764
 765 1;