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