lib/warnings.pm

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