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