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.09';
  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     'illegalproto'      => 94,
 217   );
 218
 219 our %Bits = (
 220     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
 221     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
 222     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
 223     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 224     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 225     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
 226     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 227     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
 228     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 229     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 230     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 231     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
 232     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
 233     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
 234     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
 235     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 236     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 237     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
 238     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 239     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 240     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 241     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 242     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 243     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
 244     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
 245     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 246     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
 247     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
 248     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
 249     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
 250     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
 251     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
 252     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
 253     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
 254     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
 255     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
 256     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
 257     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
 258     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
 259     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40", # [28..38,47]
 260     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
 261     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
 262     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
 263     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 264     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
 265     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 266     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 267     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 268   );
 269
 270 our %DeadBits = (
 271     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
 272     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
 273     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
 274     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 275     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 276     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
 277     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 278     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
 279     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 280     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 281     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 282     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
 283     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
 284     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
 285     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
 286     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 287     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 288     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
 289     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 290     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 291     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 292     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 293     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 294     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
 295     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
 296     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 297     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
 298     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
 299     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
 300     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
 301     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
 302     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
 303     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
 304     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
 305     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
 306     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
 307     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
 308     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
 309     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
 310     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80", # [28..38,47]
 311     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
 312     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
 313     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
 314     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 315     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
 316     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
 317     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
 318     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
 319   );
 320
 321 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
 322 $LAST_BIT = 96 ;
 323 $BYTES    = 12 ;
 324
 325 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 326
 327 sub Croaker
 328 {
 329     require Carp; # this initializes %CarpInternal
 330     local $Carp::CarpInternal{'warnings'};
 331     delete $Carp::CarpInternal{'warnings'};
 332     Carp::croak(@_);
 333 }
 334
 335 sub bits
 336 {
 337     # called from B::Deparse.pm
 338
 339     push @_, 'all' unless @_;
 340
 341     my $mask;
 342     my $catmask ;
 343     my $fatal = 0 ;
 344     my $no_fatal = 0 ;
 345
 346     foreach my $word ( @_ ) {
 347         if ($word eq 'FATAL') {
 348             $fatal = 1;
 349             $no_fatal = 0;
 350         }
 351         elsif ($word eq 'NONFATAL') {
 352             $fatal = 0;
 353             $no_fatal = 1;
 354         }
 355         elsif ($catmask = $Bits{$word}) {
 356             $mask |= $catmask ;
 357             $mask |= $DeadBits{$word} if $fatal ;
 358             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 359         }
 360         else
 361           { Croaker("Unknown warnings category '$word'")}
 362     }
 363
 364     return $mask ;
 365 }
 366
 367 sub import
 368 {
 369     shift;
 370
 371     my $catmask ;
 372     my $fatal = 0 ;
 373     my $no_fatal = 0 ;
 374
 375     my $mask = ${^WARNING_BITS} ;
 376
 377     if (vec($mask, $Offsets{'all'}, 1)) {
 378         $mask |= $Bits{'all'} ;
 379         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 380     }
 381
 382     push @_, 'all' unless @_;
 383
 384     foreach my $word ( @_ ) {
 385         if ($word eq 'FATAL') {
 386             $fatal = 1;
 387             $no_fatal = 0;
 388         }
 389         elsif ($word eq 'NONFATAL') {
 390             $fatal = 0;
 391             $no_fatal = 1;
 392         }
 393         elsif ($catmask = $Bits{$word}) {
 394             $mask |= $catmask ;
 395             $mask |= $DeadBits{$word} if $fatal ;
 396             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 397         }
 398         else
 399           { Croaker("Unknown warnings category '$word'")}
 400     }
 401
 402     ${^WARNING_BITS} = $mask ;
 403 }
 404
 405 sub unimport
 406 {
 407     shift;
 408
 409     my $catmask ;
 410     my $mask = ${^WARNING_BITS} ;
 411
 412     if (vec($mask, $Offsets{'all'}, 1)) {
 413         $mask |= $Bits{'all'} ;
 414         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 415     }
 416
 417     push @_, 'all' unless @_;
 418
 419     foreach my $word ( @_ ) {
 420         if ($word eq 'FATAL') {
 421             next;
 422         }
 423         elsif ($catmask = $Bits{$word}) {
 424             $mask &= ~($catmask | $DeadBits{$word} | $All);
 425         }
 426         else
 427           { Croaker("Unknown warnings category '$word'")}
 428     }
 429
 430     ${^WARNING_BITS} = $mask ;
 431 }
 432
 433 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 434
 435 sub __chk
 436 {
 437     my $category ;
 438     my $offset ;
 439     my $isobj = 0 ;
 440
 441     if (@_) {
 442         # check the category supplied.
 443         $category = shift ;
 444         if (my $type = ref $category) {
 445             Croaker("not an object")
 446                 if exists $builtin_type{$type};
 447             $category = $type;
 448             $isobj = 1 ;
 449         }
 450         $offset = $Offsets{$category};
 451         Croaker("Unknown warnings category '$category'")
 452             unless defined $offset;
 453     }
 454     else {
 455         $category = (caller(1))[0] ;
 456         $offset = $Offsets{$category};
 457         Croaker("package '$category' not registered for warnings")
 458             unless defined $offset ;
 459     }
 460
 461     my $this_pkg = (caller(1))[0] ;
 462     my $i = 2 ;
 463     my $pkg ;
 464
 465     if ($isobj) {
 466         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 467             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 468         }
 469         $i -= 2 ;
 470     }
 471     else {
 472         $i = _error_loc(); # see where Carp will allocate the error
 473     }
 474
 475     my $callers_bitmask = (caller($i))[9] ;
 476     return ($callers_bitmask, $offset, $i) ;
 477 }
 478
 479 sub _error_loc {
 480     require Carp;
 481     goto &Carp::short_error_loc; # don't introduce another stack frame
 482 }
 483
 484 sub enabled
 485 {
 486     Croaker("Usage: warnings::enabled([category])")
 487         unless @_ == 1 || @_ == 0 ;
 488
 489     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 490
 491     return 0 unless defined $callers_bitmask ;
 492     return vec($callers_bitmask, $offset, 1) ||
 493            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 494 }
 495
 496 sub fatal_enabled
 497 {
 498     Croaker("Usage: warnings::fatal_enabled([category])")
 499   unless @_ == 1 || @_ == 0 ;
 500
 501     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 502
 503     return 0 unless defined $callers_bitmask;
 504     return vec($callers_bitmask, $offset + 1, 1) ||
 505            vec($callers_bitmask, $Offsets{'all'} + 1, 1) ;
 506 }
 507
 508 sub warn
 509 {
 510     Croaker("Usage: warnings::warn([category,] 'message')")
 511         unless @_ == 2 || @_ == 1 ;
 512
 513     my $message = pop ;
 514     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 515     require Carp;
 516     Carp::croak($message)
 517         if vec($callers_bitmask, $offset+1, 1) ||
 518            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 519     Carp::carp($message) ;
 520 }
 521
 522 sub warnif
 523 {
 524     Croaker("Usage: warnings::warnif([category,] 'message')")
 525         unless @_ == 2 || @_ == 1 ;
 526
 527     my $message = pop ;
 528     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 529
 530     return
 531         unless defined $callers_bitmask &&
 532                 (vec($callers_bitmask, $offset, 1) ||
 533                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 534
 535     require Carp;
 536     Carp::croak($message)
 537         if vec($callers_bitmask, $offset+1, 1) ||
 538            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 539
 540     Carp::carp($message) ;
 541 }
 542
 543 1;
 544 # ex: set ro: