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