lib/warnings.pm

   1 # -*- buffer-read-only: t -*-
   2 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
   3 # This file was created by regen/warnings.pl
   4 # Any changes made here will be lost.
   5 #
   6
   7 package warnings;
   8
   9 our $VERSION = '1.11';
  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 =item warnings::register_categories(@names)
 157
 158 This registers warning categories for the given names and is primarily for
 159 use by the warnings::register pragma, for which see L<perllexwarn>.
 160
 161 =back
 162
 163 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 164
 165 =cut
 166
 167 our %Offsets = (
 168
 169     # Warnings Categories added in Perl 5.008
 170
 171     'all'               => 0,
 172     'closure'           => 2,
 173     'deprecated'        => 4,
 174     'exiting'           => 6,
 175     'glob'              => 8,
 176     'io'                => 10,
 177     'closed'            => 12,
 178     'exec'              => 14,
 179     'layer'             => 16,
 180     'newline'           => 18,
 181     'pipe'              => 20,
 182     'unopened'          => 22,
 183     'misc'              => 24,
 184     'numeric'           => 26,
 185     'once'              => 28,
 186     'overflow'          => 30,
 187     'pack'              => 32,
 188     'portable'          => 34,
 189     'recursion'         => 36,
 190     'redefine'          => 38,
 191     'regexp'            => 40,
 192     'severe'            => 42,
 193     'debugging'         => 44,
 194     'inplace'           => 46,
 195     'internal'          => 48,
 196     'malloc'            => 50,
 197     'signal'            => 52,
 198     'substr'            => 54,
 199     'syntax'            => 56,
 200     'ambiguous'         => 58,
 201     'bareword'          => 60,
 202     'digit'             => 62,
 203     'parenthesis'       => 64,
 204     'precedence'        => 66,
 205     'printf'            => 68,
 206     'prototype'         => 70,
 207     'qw'                => 72,
 208     'reserved'          => 74,
 209     'semicolon'         => 76,
 210     'taint'             => 78,
 211     'threads'           => 80,
 212     'uninitialized'     => 82,
 213     'unpack'            => 84,
 214     'untie'             => 86,
 215     'utf8'              => 88,
 216     'void'              => 90,
 217
 218     # Warnings Categories added in Perl 5.011
 219
 220     'imprecision'       => 92,
 221     'illegalproto'      => 94,
 222   );
 223
 224 our %Bits = (
 225     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
 226     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
 227     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
 228     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 229     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 230     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
 231     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 232     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
 233     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 234     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 235     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 236     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
 237     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
 238     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
 239     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
 240     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 241     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 242     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
 243     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 244     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 245     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 246     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 247     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 248     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
 249     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
 250     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 251     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
 252     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
 253     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
 254     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
 255     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
 256     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
 257     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
 258     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
 259     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
 260     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
 261     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
 262     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
 263     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
 264     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40", # [28..38,47]
 265     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
 266     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
 267     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
 268     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 269     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
 270     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 271     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 272     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 273   );
 274
 275 our %DeadBits = (
 276     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
 277     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
 278     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
 279     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 280     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 281     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
 282     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 283     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
 284     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 285     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 286     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 287     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
 288     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
 289     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
 290     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
 291     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 292     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 293     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
 294     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 295     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 296     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 297     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 298     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 299     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
 300     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
 301     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 302     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
 303     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
 304     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
 305     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
 306     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
 307     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
 308     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
 309     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
 310     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
 311     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
 312     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
 313     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
 314     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
 315     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80", # [28..38,47]
 316     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
 317     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
 318     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
 319     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 320     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
 321     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
 322     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
 323     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
 324   );
 325
 326 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
 327 $LAST_BIT = 96 ;
 328 $BYTES    = 12 ;
 329
 330 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 331
 332 sub Croaker
 333 {
 334     require Carp; # this initializes %CarpInternal
 335     local $Carp::CarpInternal{'warnings'};
 336     delete $Carp::CarpInternal{'warnings'};
 337     Carp::croak(@_);
 338 }
 339
 340 sub _bits {
 341     my $mask = shift ;
 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 bits
 368 {
 369     # called from B::Deparse.pm
 370     push @_, 'all' unless @_ ;
 371     return _bits(undef, @_) ;
 372 }
 373
 374 sub import
 375 {
 376     shift;
 377
 378     my $mask = ${^WARNING_BITS} ;
 379
 380     if (vec($mask, $Offsets{'all'}, 1)) {
 381         $mask |= $Bits{'all'} ;
 382         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 383     }
 384
 385     # Empty @_ is equivalent to @_ = 'all' ;
 386     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
 387 }
 388
 389 sub unimport
 390 {
 391     shift;
 392
 393     my $catmask ;
 394     my $mask = ${^WARNING_BITS} ;
 395
 396     if (vec($mask, $Offsets{'all'}, 1)) {
 397         $mask |= $Bits{'all'} ;
 398         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 399     }
 400
 401     push @_, 'all' unless @_;
 402
 403     foreach my $word ( @_ ) {
 404         if ($word eq 'FATAL') {
 405             next;
 406         }
 407         elsif ($catmask = $Bits{$word}) {
 408             $mask &= ~($catmask | $DeadBits{$word} | $All);
 409         }
 410         else
 411           { Croaker("Unknown warnings category '$word'")}
 412     }
 413
 414     ${^WARNING_BITS} = $mask ;
 415 }
 416
 417 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 418
 419 sub MESSAGE () { 4 };
 420 sub FATAL () { 2 };
 421 sub NORMAL () { 1 };
 422
 423 sub __chk
 424 {
 425     my $category ;
 426     my $offset ;
 427     my $isobj = 0 ;
 428     my $wanted = shift;
 429     my $has_message = $wanted & MESSAGE;
 430
 431     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
 432         my $sub = (caller 1)[3];
 433         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
 434         Croaker("Usage: $sub($syntax)");
 435     }
 436
 437     my $message = pop if $has_message;
 438
 439     if (@_) {
 440         # check the category supplied.
 441         $category = shift ;
 442         if (my $type = ref $category) {
 443             Croaker("not an object")
 444                 if exists $builtin_type{$type};
 445             $category = $type;
 446             $isobj = 1 ;
 447         }
 448         $offset = $Offsets{$category};
 449         Croaker("Unknown warnings category '$category'")
 450             unless defined $offset;
 451     }
 452     else {
 453         $category = (caller(1))[0] ;
 454         $offset = $Offsets{$category};
 455         Croaker("package '$category' not registered for warnings")
 456             unless defined $offset ;
 457     }
 458
 459     my $i;
 460
 461     if ($isobj) {
 462         my $pkg;
 463         $i = 2;
 464         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 465             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 466         }
 467         $i -= 2 ;
 468     }
 469     else {
 470         $i = _error_loc(); # see where Carp will allocate the error
 471     }
 472
 473     # Defaulting this to 0 reduces complexity in code paths below.
 474     my $callers_bitmask = (caller($i))[9] || 0 ;
 475
 476     my @results;
 477     foreach my $type (FATAL, NORMAL) {
 478         next unless $wanted & $type;
 479
 480         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
 481                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
 482     }
 483
 484     # &enabled and &fatal_enabled
 485     return $results[0] unless $has_message;
 486
 487     # &warnif, and the category is neither enabled as warning nor as fatal
 488     return if $wanted == (NORMAL | FATAL | MESSAGE)
 489         && !($results[0] || $results[1]);
 490
 491     require Carp;
 492     Carp::croak($message) if $results[0];
 493     # will always get here for &warn. will only get here for &warnif if the
 494     # category is enabled
 495     Carp::carp($message);
 496 }
 497
 498 sub _mkMask
 499 {
 500     my ($bit) = @_;
 501     my $mask = "";
 502
 503     vec($mask, $bit, 1) = 1;
 504     return $mask;
 505 }
 506
 507 sub register_categories
 508 {
 509     my @names = @_;
 510
 511     for my $name (@names) {
 512         if (! defined $Bits{$name}) {
 513             $Bits{$name}     = _mkMask($LAST_BIT);
 514             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
 515             $Offsets{$name}  = $LAST_BIT ++;
 516             foreach my $k (keys %Bits) {
 517                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
 518             }
 519             $DeadBits{$name} = _mkMask($LAST_BIT);
 520             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
 521         }
 522     }
 523 }
 524
 525 sub _error_loc {
 526     require Carp;
 527     goto &Carp::short_error_loc; # don't introduce another stack frame
 528 }
 529
 530 sub enabled
 531 {
 532     return __chk(NORMAL, @_);
 533 }
 534
 535 sub fatal_enabled
 536 {
 537     return __chk(FATAL, @_);
 538 }
 539
 540 sub warn
 541 {
 542     return __chk(FATAL | MESSAGE, @_);
 543 }
 544
 545 sub warnif
 546 {
 547     return __chk(NORMAL | FATAL | MESSAGE, @_);
 548 }
 549
 550 # These are not part of any public interface, so we can delete them to save
 551 # space.
 552 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
 553
 554 1;
 555 # ex: set ro: