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