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