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