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