lib/warnings.pm

   1 # -*- buffer-read-only: t -*-
   2 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
   3 # This file was created by warnings.pl
   4 # Any changes made here will be lost.
   5 #
   6
   7 package warnings;
   8
   9 our $VERSION = '1.08';
  10
  11 # Verify that we're called correctly so that warnings will work.
  12 # see also strict.pm.
  13 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
  14     my (undef, $f, $l) = caller;
  15     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
  16 }
  17
  18 =head1 NAME
  19
  20 warnings - Perl pragma to control optional warnings
  21
  22 =head1 SYNOPSIS
  23
  24     use warnings;
  25     no warnings;
  26
  27     use warnings "all";
  28     no warnings "all";
  29
  30     use warnings::register;
  31     if (warnings::enabled()) {
  32         warnings::warn("some warning");
  33     }
  34
  35     if (warnings::enabled("void")) {
  36         warnings::warn("void", "some warning");
  37     }
  38
  39     if (warnings::enabled($object)) {
  40         warnings::warn($object, "some warning");
  41     }
  42
  43     warnings::warnif("some warning");
  44     warnings::warnif("void", "some warning");
  45     warnings::warnif($object, "some warning");
  46
  47 =head1 DESCRIPTION
  48
  49 The C<warnings> pragma is a replacement for the command line flag C<-w>,
  50 but the pragma is limited to the enclosing block, while the flag is global.
  51 See L<perllexwarn> for more information.
  52
  53 If no import list is supplied, all possible warnings are either enabled
  54 or disabled.
  55
  56 A number of functions are provided to assist module authors.
  57
  58 =over 4
  59
  60 =item use warnings::register
  61
  62 Creates a new warnings category with the same name as the package where
  63 the call to the pragma is used.
  64
  65 =item warnings::enabled()
  66
  67 Use the warnings category with the same name as the current package.
  68
  69 Return TRUE if that warnings category is enabled in the calling module.
  70 Otherwise returns FALSE.
  71
  72 =item warnings::enabled($category)
  73
  74 Return TRUE if the warnings category, C<$category>, is enabled in the
  75 calling module.
  76 Otherwise returns FALSE.
  77
  78 =item warnings::enabled($object)
  79
  80 Use the name of the class for the object reference, C<$object>, as the
  81 warnings category.
  82
  83 Return TRUE if that warnings category is enabled in the first scope
  84 where the object is used.
  85 Otherwise returns FALSE.
  86
  87 =item warnings::fatal_enabled()
  88
  89 Return TRUE if the warnings category with the same name as the current
  90 package has been set to FATAL in the calling module.
  91 Otherwise returns FALSE.
  92
  93 =item warnings::fatal_enabled($category)
  94
  95 Return TRUE if the warnings category C<$category> has been set to FATAL in
  96 the calling module.
  97 Otherwise returns FALSE.
  98
  99 =item warnings::fatal_enabled($object)
 100
 101 Use the name of the class for the object reference, C<$object>, as the
 102 warnings category.
 103
 104 Return TRUE if that warnings category has been set to FATAL in the first
 105 scope where the object is used.
 106 Otherwise returns FALSE.
 107
 108 =item warnings::warn($message)
 109
 110 Print C<$message> to STDERR.
 111
 112 Use the warnings category with the same name as the current package.
 113
 114 If that warnings category has been set to "FATAL" in the calling module
 115 then die. Otherwise return.
 116
 117 =item warnings::warn($category, $message)
 118
 119 Print C<$message> to STDERR.
 120
 121 If the warnings category, C<$category>, has been set to "FATAL" in the
 122 calling module then die. Otherwise return.
 123
 124 =item warnings::warn($object, $message)
 125
 126 Print C<$message> to STDERR.
 127
 128 Use the name of the class for the object reference, C<$object>, as the
 129 warnings category.
 130
 131 If that warnings category has been set to "FATAL" in the scope where C<$object>
 132 is first used then die. Otherwise return.
 133
 134
 135 =item warnings::warnif($message)
 136
 137 Equivalent to:
 138
 139     if (warnings::enabled())
 140       { warnings::warn($message) }
 141
 142 =item warnings::warnif($category, $message)
 143
 144 Equivalent to:
 145
 146     if (warnings::enabled($category))
 147       { warnings::warn($category, $message) }
 148
 149 =item warnings::warnif($object, $message)
 150
 151 Equivalent to:
 152
 153     if (warnings::enabled($object))
 154       { warnings::warn($object, $message) }
 155
 156 =back
 157
 158 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 159
 160 =cut
 161
 162 our %Offsets = (
 163
 164     # Warnings Categories added in Perl 5.008
 165
 166     'all'               => 0,
 167     'closure'           => 2,
 168     'deprecated'        => 4,
 169     'exiting'           => 6,
 170     'glob'              => 8,
 171     'io'                => 10,
 172     'closed'            => 12,
 173     'exec'              => 14,
 174     'layer'             => 16,
 175     'newline'           => 18,
 176     'pipe'              => 20,
 177     'unopened'          => 22,
 178     'misc'              => 24,
 179     'numeric'           => 26,
 180     'once'              => 28,
 181     'overflow'          => 30,
 182     'pack'              => 32,
 183     'portable'          => 34,
 184     'recursion'         => 36,
 185     'redefine'          => 38,
 186     'regexp'            => 40,
 187     'severe'            => 42,
 188     'debugging'         => 44,
 189     'inplace'           => 46,
 190     'internal'          => 48,
 191     'malloc'            => 50,
 192     'signal'            => 52,
 193     'substr'            => 54,
 194     'syntax'            => 56,
 195     'ambiguous'         => 58,
 196     'bareword'          => 60,
 197     'digit'             => 62,
 198     'parenthesis'       => 64,
 199     'precedence'        => 66,
 200     'printf'            => 68,
 201     'prototype'         => 70,
 202     'qw'                => 72,
 203     'reserved'          => 74,
 204     'semicolon'         => 76,
 205     'taint'             => 78,
 206     'threads'           => 80,
 207     'uninitialized'     => 82,
 208     'unpack'            => 84,
 209     'untie'             => 86,
 210     'utf8'              => 88,
 211     'void'              => 90,
 212
 213     # Warnings Categories added in Perl 5.011
 214
 215     'imprecision'       => 92,
 216   );
 217
 218 our %Bits = (
 219     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
 220     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
 221     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
 222     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 223     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 224     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
 225     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 226     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
 227     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 228     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 229     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 230     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
 231     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
 232     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
 233     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 234     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 235     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
 236     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 237     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 238     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 239     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 240     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 241     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
 242     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
 243     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 244     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
 245     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
 246     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
 247     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
 248     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
 249     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
 250     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
 251     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
 252     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
 253     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
 254     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
 255     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
 256     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
 257     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
 258     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
 259     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
 260     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
 261     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 262     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
 263     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 264     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 265     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 266   );
 267
 268 our %DeadBits = (
 269     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
 270     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
 271     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
 272     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 273     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 274     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
 275     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 276     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
 277     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 278     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 279     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 280     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
 281     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
 282     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
 283     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 284     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 285     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
 286     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 287     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 288     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 289     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 290     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 291     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
 292     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
 293     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 294     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
 295     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
 296     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
 297     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
 298     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
 299     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
 300     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
 301     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
 302     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
 303     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
 304     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
 305     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
 306     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
 307     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
 308     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
 309     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
 310     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
 311     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 312     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
 313     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
 314     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
 315     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
 316   );
 317
 318 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
 319 $LAST_BIT = 94 ;
 320 $BYTES    = 12 ;
 321
 322 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 323
 324 sub Croaker
 325 {
 326     require Carp; # this initializes %CarpInternal
 327     local $Carp::CarpInternal{'warnings'};
 328     delete $Carp::CarpInternal{'warnings'};
 329     Carp::croak(@_);
 330 }
 331
 332 sub bits
 333 {
 334     # called from B::Deparse.pm
 335
 336     push @_, 'all' unless @_;
 337
 338     my $mask;
 339     my $catmask ;
 340     my $fatal = 0 ;
 341     my $no_fatal = 0 ;
 342
 343     foreach my $word ( @_ ) {
 344         if ($word eq 'FATAL') {
 345             $fatal = 1;
 346             $no_fatal = 0;
 347         }
 348         elsif ($word eq 'NONFATAL') {
 349             $fatal = 0;
 350             $no_fatal = 1;
 351         }
 352         elsif ($catmask = $Bits{$word}) {
 353             $mask |= $catmask ;
 354             $mask |= $DeadBits{$word} if $fatal ;
 355             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 356         }
 357         else
 358           { Croaker("Unknown warnings category '$word'")}
 359     }
 360
 361     return $mask ;
 362 }
 363
 364 sub import
 365 {
 366     shift;
 367
 368     my $catmask ;
 369     my $fatal = 0 ;
 370     my $no_fatal = 0 ;
 371
 372     my $mask = ${^WARNING_BITS} ;
 373
 374     if (vec($mask, $Offsets{'all'}, 1)) {
 375         $mask |= $Bits{'all'} ;
 376         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 377     }
 378
 379     push @_, 'all' unless @_;
 380
 381     foreach my $word ( @_ ) {
 382         if ($word eq 'FATAL') {
 383             $fatal = 1;
 384             $no_fatal = 0;
 385         }
 386         elsif ($word eq 'NONFATAL') {
 387             $fatal = 0;
 388             $no_fatal = 1;
 389         }
 390         elsif ($catmask = $Bits{$word}) {
 391             $mask |= $catmask ;
 392             $mask |= $DeadBits{$word} if $fatal ;
 393             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 394         }
 395         else
 396           { Croaker("Unknown warnings category '$word'")}
 397     }
 398
 399     ${^WARNING_BITS} = $mask ;
 400 }
 401
 402 sub unimport
 403 {
 404     shift;
 405
 406     my $catmask ;
 407     my $mask = ${^WARNING_BITS} ;
 408
 409     if (vec($mask, $Offsets{'all'}, 1)) {
 410         $mask |= $Bits{'all'} ;
 411         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 412     }
 413
 414     push @_, 'all' unless @_;
 415
 416     foreach my $word ( @_ ) {
 417         if ($word eq 'FATAL') {
 418             next;
 419         }
 420         elsif ($catmask = $Bits{$word}) {
 421             $mask &= ~($catmask | $DeadBits{$word} | $All);
 422         }
 423         else
 424           { Croaker("Unknown warnings category '$word'")}
 425     }
 426
 427     ${^WARNING_BITS} = $mask ;
 428 }
 429
 430 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 431
 432 sub __chk
 433 {
 434     my $category ;
 435     my $offset ;
 436     my $isobj = 0 ;
 437
 438     if (@_) {
 439         # check the category supplied.
 440         $category = shift ;
 441         if (my $type = ref $category) {
 442             Croaker("not an object")
 443                 if exists $builtin_type{$type};
 444             $category = $type;
 445             $isobj = 1 ;
 446         }
 447         $offset = $Offsets{$category};
 448         Croaker("Unknown warnings category '$category'")
 449             unless defined $offset;
 450     }
 451     else {
 452         $category = (caller(1))[0] ;
 453         $offset = $Offsets{$category};
 454         Croaker("package '$category' not registered for warnings")
 455             unless defined $offset ;
 456     }
 457
 458     my $this_pkg = (caller(1))[0] ;
 459     my $i = 2 ;
 460     my $pkg ;
 461
 462     if ($isobj) {
 463         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 464             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 465         }
 466         $i -= 2 ;
 467     }
 468     else {
 469         $i = _error_loc(); # see where Carp will allocate the error
 470     }
 471
 472     my $callers_bitmask = (caller($i))[9] ;
 473     return ($callers_bitmask, $offset, $i) ;
 474 }
 475
 476 sub _error_loc {
 477     require Carp;
 478     goto &Carp::short_error_loc; # don't introduce another stack frame
 479 }
 480
 481 sub enabled
 482 {
 483     Croaker("Usage: warnings::enabled([category])")
 484         unless @_ == 1 || @_ == 0 ;
 485
 486     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 487
 488     return 0 unless defined $callers_bitmask ;
 489     return vec($callers_bitmask, $offset, 1) ||
 490            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 491 }
 492
 493 sub fatal_enabled
 494 {
 495     Croaker("Usage: warnings::fatal_enabled([category])")
 496   unless @_ == 1 || @_ == 0 ;
 497
 498     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 499
 500     return 0 unless defined $callers_bitmask;
 501     return vec($callers_bitmask, $offset + 1, 1) ||
 502            vec($callers_bitmask, $Offsets{'all'} + 1, 1) ;
 503 }
 504
 505 sub warn
 506 {
 507     Croaker("Usage: warnings::warn([category,] 'message')")
 508         unless @_ == 2 || @_ == 1 ;
 509
 510     my $message = pop ;
 511     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 512     require Carp;
 513     Carp::croak($message)
 514         if vec($callers_bitmask, $offset+1, 1) ||
 515            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 516     Carp::carp($message) ;
 517 }
 518
 519 sub warnif
 520 {
 521     Croaker("Usage: warnings::warnif([category,] 'message')")
 522         unless @_ == 2 || @_ == 1 ;
 523
 524     my $message = pop ;
 525     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 526
 527     return
 528         unless defined $callers_bitmask &&
 529                 (vec($callers_bitmask, $offset, 1) ||
 530                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 531
 532     require Carp;
 533     Carp::croak($message)
 534         if vec($callers_bitmask, $offset+1, 1) ||
 535            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 536
 537     Carp::carp($message) ;
 538 }
 539
 540 1;
 541 # ex: set ro: