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