warnings.pl

   1 #!/usr/bin/perl
   2
   3
   4 $VERSION = '1.00';
   5
   6 BEGIN {
   7   push @INC, './lib';
   8 }
   9 use strict ;
  10
  11 sub DEFAULT_ON  () { 1 }
  12 sub DEFAULT_OFF () { 2 }
  13
  14 my $tree = {
  15
  16 'all' => {
  17         'io'            => {    'pipe'          => DEFAULT_OFF,
  18                                 'unopened'      => DEFAULT_OFF,
  19                                 'closed'        => DEFAULT_OFF,
  20                                 'newline'       => DEFAULT_OFF,
  21                                 'exec'          => DEFAULT_OFF,
  22                                 'layer'         => DEFAULT_OFF,
  23                            },
  24         'syntax'        => {    'ambiguous'     => DEFAULT_OFF,
  25                                 'semicolon'     => DEFAULT_OFF,
  26                                 'precedence'    => DEFAULT_OFF,
  27                                 'bareword'      => DEFAULT_OFF,
  28                                 'reserved'      => DEFAULT_OFF,
  29                                 'digit'         => DEFAULT_OFF,
  30                                 'parenthesis'   => DEFAULT_OFF,
  31                                 'printf'        => DEFAULT_OFF,
  32                                 'prototype'     => DEFAULT_OFF,
  33                                 'qw'            => DEFAULT_OFF,
  34                            },
  35         'severe'        => {    'inplace'       => DEFAULT_ON,
  36                                 'internal'      => DEFAULT_ON,
  37                                 'debugging'     => DEFAULT_ON,
  38                                 'malloc'        => DEFAULT_ON,
  39                            },
  40         'deprecated'    => DEFAULT_OFF,
  41         'void'          => DEFAULT_OFF,
  42         'recursion'     => DEFAULT_OFF,
  43         'redefine'      => DEFAULT_OFF,
  44         'numeric'       => DEFAULT_OFF,
  45         'uninitialized' => DEFAULT_OFF,
  46         'once'          => DEFAULT_OFF,
  47         'misc'          => DEFAULT_OFF,
  48         'regexp'        => DEFAULT_OFF,
  49         'glob'          => DEFAULT_OFF,
  50         'y2k'           => DEFAULT_OFF,
  51         'untie'         => DEFAULT_OFF,
  52         'substr'        => DEFAULT_OFF,
  53         'taint'         => DEFAULT_OFF,
  54         'signal'        => DEFAULT_OFF,
  55         'closure'       => DEFAULT_OFF,
  56         'overflow'      => DEFAULT_OFF,
  57         'portable'      => DEFAULT_OFF,
  58         'utf8'          => DEFAULT_OFF,
  59         'exiting'       => DEFAULT_OFF,
  60         'pack'          => DEFAULT_OFF,
  61         'unpack'        => DEFAULT_OFF,
  62          #'default'     => DEFAULT_ON,
  63         }
  64 } ;
  65
  66
  67 ###########################################################################
  68 sub tab {
  69     my($l, $t) = @_;
  70     $t .= "\t" x ($l - (length($t) + 1) / 8);
  71     $t;
  72 }
  73
  74 ###########################################################################
  75
  76 my %list ;
  77 my %Value ;
  78 my $index ;
  79
  80 sub walk
  81 {
  82     my $tre = shift ;
  83     my @list = () ;
  84     my ($k, $v) ;
  85
  86     foreach $k (sort keys %$tre) {
  87         $v = $tre->{$k};
  88         die "duplicate key $k\n" if defined $list{$k} ;
  89         $Value{$index} = uc $k ;
  90         push @{ $list{$k} }, $index ++ ;
  91         if (ref $v)
  92           { push (@{ $list{$k} }, walk ($v)) }
  93         push @list, @{ $list{$k} } ;
  94     }
  95
  96    return @list ;
  97 }
  98
  99 ###########################################################################
 100
 101 sub mkRange
 102 {
 103     my @a = @_ ;
 104     my @out = @a ;
 105     my $i ;
 106
 107
 108     for ($i = 1 ; $i < @a; ++ $i) {
 109         $out[$i] = ".."
 110           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
 111     }
 112
 113     my $out = join(",",@out);
 114
 115     $out =~ s/,(\.\.,)+/../g ;
 116     return $out;
 117 }
 118
 119 ###########################################################################
 120 sub printTree
 121 {
 122     my $tre = shift ;
 123     my $prefix = shift ;
 124     my $indent = shift ;
 125     my ($k, $v) ;
 126
 127     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
 128
 129     $prefix .= " " x $indent ;
 130     foreach $k (sort keys %$tre) {
 131         $v = $tre->{$k};
 132         print $prefix . "|\n" ;
 133         print $prefix . "+- $k" ;
 134         if (ref $v)
 135         {
 136             print " " . "-" x ($max - length $k ) . "+\n" ;
 137             printTree ($v, $prefix . "|" , $max + $indent - 1)
 138         }
 139         else
 140           { print "\n" }
 141     }
 142
 143 }
 144
 145 ###########################################################################
 146
 147 sub mkHexOct
 148 {
 149     my ($f, $max, @a) = @_ ;
 150     my $mask = "\x00" x $max ;
 151     my $string = "" ;
 152
 153     foreach (@a) {
 154         vec($mask, $_, 1) = 1 ;
 155     }
 156
 157     foreach (unpack("C*", $mask)) {
 158         if ($f eq 'x') {
 159             $string .= '\x' . sprintf("%2.2x", $_)
 160         }
 161         else {
 162             $string .= '\\' . sprintf("%o", $_)
 163         }
 164     }
 165     return $string ;
 166 }
 167
 168 sub mkHex
 169 {
 170     my($max, @a) = @_;
 171     return mkHexOct("x", $max, @a);
 172 }
 173
 174 sub mkOct
 175 {
 176     my($max, @a) = @_;
 177     return mkHexOct("o", $max, @a);
 178 }
 179
 180 ###########################################################################
 181
 182 if (@ARGV && $ARGV[0] eq "tree")
 183 {
 184     #print "  all -+\n" ;
 185     printTree($tree, "   ", 4) ;
 186     exit ;
 187 }
 188
 189 unlink "warnings.h";
 190 unlink "lib/warnings.pm";
 191 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
 192 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
 193
 194 print WARN <<'EOM' ;
 195 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 196    This file is built by warnings.pl
 197    Any changes made here will be lost!
 198 */
 199
 200
 201 #define Off(x)                  ((x) / 8)
 202 #define Bit(x)                  (1 << ((x) % 8))
 203 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
 204
 205
 206 #define G_WARN_OFF              0       /* $^W == 0 */
 207 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
 208 #define G_WARN_ALL_ON           2       /* -W flag */
 209 #define G_WARN_ALL_OFF          4       /* -X flag */
 210 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
 211 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 212
 213 #define pWARN_STD               Nullsv
 214 #define pWARN_ALL               (Nullsv+1)      /* use warnings 'all' */
 215 #define pWARN_NONE              (Nullsv+2)      /* no  warnings 'all' */
 216
 217 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
 218                                  (x) == pWARN_NONE)
 219 EOM
 220
 221 my $offset = 0 ;
 222
 223 $index = $offset ;
 224 #@{ $list{"all"} } = walk ($tree) ;
 225 walk ($tree) ;
 226
 227 die <<EOM if $index > 255 ;
 228 Too many warnings categories -- max is 255
 229     rewrite packWARN* & unpackWARN* macros
 230 EOM
 231
 232 $index *= 2 ;
 233 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 234
 235 my $k ;
 236 foreach $k (sort { $a <=> $b } keys %Value) {
 237     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
 238 }
 239 print WARN "\n" ;
 240
 241 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
 242 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 243 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 244 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
 245 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
 246
 247 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
 248
 249 print WARN <<'EOM';
 250
 251 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
 252 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
 253 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 254 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
 255 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
 256
 257 #define ckWARN(x)                                                       \
 258         ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&     \
 259               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 260                isWARN_on(PL_curcop->cop_warnings, x) ) )                \
 261           || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 262
 263 #define ckWARN2(x,y)                                                    \
 264           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 265               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 266                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 267                 isWARN_on(PL_curcop->cop_warnings, y) ) )               \
 268             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 269
 270 #define ckWARN3(x,y,z)                                                  \
 271           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 272               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 273                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 274                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
 275                 isWARN_on(PL_curcop->cop_warnings, z) ) )               \
 276             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 277
 278 #define ckWARN4(x,y,z,t)                                                \
 279           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 280               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 281                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 282                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
 283                 isWARN_on(PL_curcop->cop_warnings, z)  ||               \
 284                 isWARN_on(PL_curcop->cop_warnings, t) ) )               \
 285             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 286
 287 #define ckWARN_d(x)                                                     \
 288           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 289              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 290               isWARN_on(PL_curcop->cop_warnings, x) ) )
 291
 292 #define ckWARN2_d(x,y)                                                  \
 293           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 294              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 295                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 296                  isWARN_on(PL_curcop->cop_warnings, y) ) ) )
 297
 298 #define ckWARN3_d(x,y,z)                                                \
 299           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 300              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 301                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 302                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
 303                  isWARN_on(PL_curcop->cop_warnings, z) ) ) )
 304
 305 #define ckWARN4_d(x,y,z,t)                                              \
 306           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 307              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 308                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 309                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
 310                  isWARN_on(PL_curcop->cop_warnings, z)  ||              \
 311                  isWARN_on(PL_curcop->cop_warnings, t) ) ) )
 312
 313 #define packWARN(a)             (a                                 )
 314 #define packWARN2(a,b)          ((a) | (b)<<8                      )
 315 #define packWARN3(a,b,c)        ((a) | (b)<<8 | (c) <<16           )
 316 #define packWARN4(a,b,c,d)      ((a) | (b)<<8 | (c) <<16 | (d) <<24)
 317
 318 #define unpackWARN1(x)          ((x)        & 0xFF)
 319 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
 320 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
 321 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
 322
 323 #define ckDEAD(x)                                                       \
 324            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 325             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
 326               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
 327               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
 328               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
 329               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
 330
 331 /* end of file warnings.h */
 332
 333 EOM
 334
 335 close WARN ;
 336
 337 while (<DATA>) {
 338     last if /^KEYWORDS$/ ;
 339     print PM $_ ;
 340 }
 341
 342 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
 343
 344 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
 345
 346 print PM "%Offsets = (\n" ;
 347 foreach my $k (sort { $a <=> $b } keys %Value) {
 348     my $v = lc $Value{$k} ;
 349     $k *= 2 ;
 350     print PM tab(4, "    '$v'"), "=> $k,\n" ;
 351 }
 352
 353 print PM "  );\n\n" ;
 354
 355 print PM "%Bits = (\n" ;
 356 foreach $k (sort keys  %list) {
 357
 358     my $v = $list{$k} ;
 359     my @list = sort { $a <=> $b } @$v ;
 360
 361     print PM tab(4, "    '$k'"), '=> "',
 362                 # mkHex($warn_size, @list),
 363                 mkHex($warn_size, map $_ * 2 , @list),
 364                 '", # [', mkRange(@list), "]\n" ;
 365 }
 366
 367 print PM "  );\n\n" ;
 368
 369 print PM "%DeadBits = (\n" ;
 370 foreach $k (sort keys  %list) {
 371
 372     my $v = $list{$k} ;
 373     my @list = sort { $a <=> $b } @$v ;
 374
 375     print PM tab(4, "    '$k'"), '=> "',
 376                 # mkHex($warn_size, @list),
 377                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 378                 '", # [', mkRange(@list), "]\n" ;
 379 }
 380
 381 print PM "  );\n\n" ;
 382 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
 383 print PM '$LAST_BIT = ' . "$index ;\n" ;
 384 print PM '$BYTES    = ' . "$warn_size ;\n" ;
 385 while (<DATA>) {
 386     print PM $_ ;
 387 }
 388
 389 close PM ;
 390
 391 __END__
 392
 393 # This file was created by warnings.pl
 394 # Any changes made here will be lost.
 395 #
 396
 397 package warnings;
 398
 399 our $VERSION = '1.00';
 400
 401 =head1 NAME
 402
 403 warnings - Perl pragma to control optional warnings
 404
 405 =head1 SYNOPSIS
 406
 407     use warnings;
 408     no warnings;
 409
 410     use warnings "all";
 411     no warnings "all";
 412
 413     use warnings::register;
 414     if (warnings::enabled()) {
 415         warnings::warn("some warning");
 416     }
 417
 418     if (warnings::enabled("void")) {
 419         warnings::warn("void", "some warning");
 420     }
 421
 422     if (warnings::enabled($object)) {
 423         warnings::warn($object, "some warning");
 424     }
 425
 426     warnings::warnif("some warning");
 427     warnings::warnif("void", "some warning");
 428     warnings::warnif($object, "some warning");
 429
 430 =head1 DESCRIPTION
 431
 432 If no import list is supplied, all possible warnings are either enabled
 433 or disabled.
 434
 435 A number of functions are provided to assist module authors.
 436
 437 =over 4
 438
 439 =item use warnings::register
 440
 441 Creates a new warnings category with the same name as the package where
 442 the call to the pragma is used.
 443
 444 =item warnings::enabled()
 445
 446 Use the warnings category with the same name as the current package.
 447
 448 Return TRUE if that warnings category is enabled in the calling module.
 449 Otherwise returns FALSE.
 450
 451 =item warnings::enabled($category)
 452
 453 Return TRUE if the warnings category, C<$category>, is enabled in the
 454 calling module.
 455 Otherwise returns FALSE.
 456
 457 =item warnings::enabled($object)
 458
 459 Use the name of the class for the object reference, C<$object>, as the
 460 warnings category.
 461
 462 Return TRUE if that warnings category is enabled in the first scope
 463 where the object is used.
 464 Otherwise returns FALSE.
 465
 466 =item warnings::warn($message)
 467
 468 Print C<$message> to STDERR.
 469
 470 Use the warnings category with the same name as the current package.
 471
 472 If that warnings category has been set to "FATAL" in the calling module
 473 then die. Otherwise return.
 474
 475 =item warnings::warn($category, $message)
 476
 477 Print C<$message> to STDERR.
 478
 479 If the warnings category, C<$category>, has been set to "FATAL" in the
 480 calling module then die. Otherwise return.
 481
 482 =item warnings::warn($object, $message)
 483
 484 Print C<$message> to STDERR.
 485
 486 Use the name of the class for the object reference, C<$object>, as the
 487 warnings category.
 488
 489 If that warnings category has been set to "FATAL" in the scope where C<$object>
 490 is first used then die. Otherwise return.
 491
 492
 493 =item warnings::warnif($message)
 494
 495 Equivalent to:
 496
 497     if (warnings::enabled())
 498       { warnings::warn($message) }
 499
 500 =item warnings::warnif($category, $message)
 501
 502 Equivalent to:
 503
 504     if (warnings::enabled($category))
 505       { warnings::warn($category, $message) }
 506
 507 =item warnings::warnif($object, $message)
 508
 509 Equivalent to:
 510
 511     if (warnings::enabled($object))
 512       { warnings::warn($object, $message) }
 513
 514 =back
 515
 516 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 517
 518 =cut
 519
 520 use Carp ;
 521
 522 KEYWORDS
 523
 524 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 525
 526 sub Croaker
 527 {
 528     delete $Carp::CarpInternal{'warnings'};
 529     croak @_ ;
 530 }
 531
 532 sub bits {
 533     my $mask ;
 534     my $catmask ;
 535     my $fatal = 0 ;
 536     foreach my $word (@_) {
 537         if  ($word eq 'FATAL') {
 538             $fatal = 1;
 539         }
 540         elsif ($catmask = $Bits{$word}) {
 541             $mask |= $catmask ;
 542             $mask |= $DeadBits{$word} if $fatal ;
 543         }
 544         else
 545           { Croaker("Unknown warnings category '$word'")}
 546     }
 547
 548     return $mask ;
 549 }
 550
 551 sub import {
 552     shift;
 553     my $mask = ${^WARNING_BITS} ;
 554     if (vec($mask, $Offsets{'all'}, 1)) {
 555         $mask |= $Bits{'all'} ;
 556         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 557     }
 558     ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
 559 }
 560
 561 sub unimport {
 562     shift;
 563     my $mask = ${^WARNING_BITS} ;
 564     if (vec($mask, $Offsets{'all'}, 1)) {
 565         $mask |= $Bits{'all'} ;
 566         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 567     }
 568     ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
 569 }
 570
 571 sub __chk
 572 {
 573     my $category ;
 574     my $offset ;
 575     my $isobj = 0 ;
 576
 577     if (@_) {
 578         # check the category supplied.
 579         $category = shift ;
 580         if (ref $category) {
 581             Croaker ("not an object")
 582                 if $category !~ /^([^=]+)=/ ;
 583             $category = $1 ;
 584             $isobj = 1 ;
 585         }
 586         $offset = $Offsets{$category};
 587         Croaker("Unknown warnings category '$category'")
 588             unless defined $offset;
 589     }
 590     else {
 591         $category = (caller(1))[0] ;
 592         $offset = $Offsets{$category};
 593         Croaker("package '$category' not registered for warnings")
 594             unless defined $offset ;
 595     }
 596
 597     my $this_pkg = (caller(1))[0] ;
 598     my $i = 2 ;
 599     my $pkg ;
 600
 601     if ($isobj) {
 602         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 603             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 604         }
 605         $i -= 2 ;
 606     }
 607     else {
 608         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 609             last if $pkg ne $this_pkg ;
 610         }
 611         $i = 2
 612             if !$pkg || $pkg eq $this_pkg ;
 613     }
 614
 615     my $callers_bitmask = (caller($i))[9] ;
 616     return ($callers_bitmask, $offset, $i) ;
 617 }
 618
 619 sub enabled
 620 {
 621     Croaker("Usage: warnings::enabled([category])")
 622         unless @_ == 1 || @_ == 0 ;
 623
 624     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 625
 626     return 0 unless defined $callers_bitmask ;
 627     return vec($callers_bitmask, $offset, 1) ||
 628            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 629 }
 630
 631
 632 sub warn
 633 {
 634     Croaker("Usage: warnings::warn([category,] 'message')")
 635         unless @_ == 2 || @_ == 1 ;
 636
 637     my $message = pop ;
 638     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 639     croak($message)
 640         if vec($callers_bitmask, $offset+1, 1) ||
 641            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 642     carp($message) ;
 643 }
 644
 645 sub warnif
 646 {
 647     Croaker("Usage: warnings::warnif([category,] 'message')")
 648         unless @_ == 2 || @_ == 1 ;
 649
 650     my $message = pop ;
 651     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 652
 653     return
 654         unless defined $callers_bitmask &&
 655                 (vec($callers_bitmask, $offset, 1) ||
 656                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 657
 658     croak($message)
 659         if vec($callers_bitmask, $offset+1, 1) ||
 660            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 661
 662     carp($message) ;
 663 }
 664 1;