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.14';
   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 In all the descriptions below, $category can also be a warnings category
  59 and ID separated by a colon, such as "experimental:lexical_subs".  See
  60 L<perllexwarn/Individual Warning IDs>.
  61
  62 =over 4
  63
  64 =item use warnings::register
  65
  66 Creates a new warnings category with the same name as the package where
  67 the call to the pragma is used.
  68
  69 =item warnings::enabled()
  70
  71 Use the warnings category with the same name as the current package.
  72
  73 Return TRUE if that warnings category is enabled in the calling module.
  74 Otherwise returns FALSE.
  75
  76 =item warnings::enabled($category)
  77
  78 Return TRUE if the warnings category, C<$category>, is enabled in the
  79 calling module.
  80 Otherwise returns FALSE.
  81
  82 =item warnings::enabled($object)
  83
  84 Use the name of the class for the object reference, C<$object>, as the
  85 warnings category.
  86
  87 Return TRUE if that warnings category is enabled in the first scope
  88 where the object is used.
  89 Otherwise returns FALSE.
  90
  91 =item warnings::fatal_enabled()
  92
  93 Return TRUE if the warnings category with the same name as the current
  94 package has been set to FATAL in the calling module.
  95 Otherwise returns FALSE.
  96
  97 =item warnings::fatal_enabled($category)
  98
  99 Return TRUE if the warnings category C<$category> has been set to FATAL in
 100 the calling module.
 101 Otherwise returns FALSE.
 102
 103 =item warnings::fatal_enabled($object)
 104
 105 Use the name of the class for the object reference, C<$object>, as the
 106 warnings category.
 107
 108 Return TRUE if that warnings category has been set to FATAL in the first
 109 scope where the object is used.
 110 Otherwise returns FALSE.
 111
 112 =item warnings::warn($message)
 113
 114 Print C<$message> to STDERR.
 115
 116 Use the warnings category with the same name as the current package.
 117
 118 If that warnings category has been set to "FATAL" in the calling module
 119 then die. Otherwise return.
 120
 121 =item warnings::warn($category, $message)
 122
 123 Print C<$message> to STDERR.
 124
 125 If the warnings category, C<$category>, has been set to "FATAL" in the
 126 calling module then die. Otherwise return.
 127
 128 =item warnings::warn($object, $message)
 129
 130 Print C<$message> to STDERR.
 131
 132 Use the name of the class for the object reference, C<$object>, as the
 133 warnings category.
 134
 135 If that warnings category has been set to "FATAL" in the scope where C<$object>
 136 is first used then die. Otherwise return.
 137
 138
 139 =item warnings::warnif($message)
 140
 141 Equivalent to:
 142
 143     if (warnings::enabled())
 144       { warnings::warn($message) }
 145
 146 =item warnings::warnif($category, $message)
 147
 148 Equivalent to:
 149
 150     if (warnings::enabled($category))
 151       { warnings::warn($category, $message) }
 152
 153 =item warnings::warnif($object, $message)
 154
 155 Equivalent to:
 156
 157     if (warnings::enabled($object))
 158       { warnings::warn($object, $message) }
 159
 160 =item warnings::register_categories(@names)
 161
 162 This registers warning categories for the given names and is primarily for
 163 use by the warnings::register pragma, for which see L<perllexwarn>.
 164
 165 =back
 166
 167 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 168
 169 =cut
 170
 171 our %Offsets = (
 172
 173     # Warnings Categories added in Perl 5.008
 174
 175     'all'               => 0,
 176     'closure'           => 2,
 177     'deprecated'        => 4,
 178     'exiting'           => 6,
 179     'glob'              => 8,
 180     'io'                => 10,
 181     'closed'            => 12,
 182     'exec'              => 14,
 183     'layer'             => 16,
 184     'newline'           => 18,
 185     'pipe'              => 20,
 186     'unopened'          => 22,
 187     'misc'              => 24,
 188     'numeric'           => 26,
 189     'once'              => 28,
 190     'overflow'          => 30,
 191     'pack'              => 32,
 192     'portable'          => 34,
 193     'recursion'         => 36,
 194     'redefine'          => 38,
 195     'regexp'            => 40,
 196     'severe'            => 42,
 197     'debugging'         => 44,
 198     'inplace'           => 46,
 199     'internal'          => 48,
 200     'malloc'            => 50,
 201     'signal'            => 52,
 202     'substr'            => 54,
 203     'syntax'            => 56,
 204     'ambiguous'         => 58,
 205     'bareword'          => 60,
 206     'digit'             => 62,
 207     'parenthesis'       => 64,
 208     'precedence'        => 66,
 209     'printf'            => 68,
 210     'prototype'         => 70,
 211     'qw'                => 72,
 212     'reserved'          => 74,
 213     'semicolon'         => 76,
 214     'taint'             => 78,
 215     'threads'           => 80,
 216     'uninitialized'     => 82,
 217     'unpack'            => 84,
 218     'untie'             => 86,
 219     'utf8'              => 88,
 220     'void'              => 90,
 221
 222     # Warnings Categories added in Perl 5.011
 223
 224     'imprecision'       => 92,
 225     'illegalproto'      => 94,
 226
 227     # Warnings Categories added in Perl 5.013
 228
 229     'non_unicode'       => 96,
 230     'nonchar'           => 98,
 231     'surrogate'         => 100,
 232
 233     # Warnings Categories added in Perl 5.017
 234
 235     'experimental'      => 102,
 236     'experimental:lexical_subs'=> 104,
 237   );
 238
 239 our %Bits = (
 240     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..52]
 241     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [29]
 242     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [30]
 243     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 244     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 245     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
 246     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 247     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [31]
 248     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 249     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 250     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01", # [51,52]
 251     'experimental:lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [52]
 252     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 253     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [47]
 254     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [46]
 255     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
 256     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [24]
 257     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 258     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 259     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [25]
 260     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 261     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 262     'non_unicode'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [48]
 263     'nonchar'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [49]
 264     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 265     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 266     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 267     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
 268     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [32]
 269     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 270     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
 271     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [33]
 272     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [34]
 273     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [35]
 274     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [36]
 275     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
 276     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
 277     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
 278     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [37]
 279     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [38]
 280     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00", # [21..25]
 281     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [26]
 282     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [27]
 283     'surrogate'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [50]
 284     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00", # [28..38,47]
 285     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [39]
 286     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [40]
 287     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [41]
 288     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 289     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [42]
 290     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [43]
 291     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00", # [44,48..50]
 292     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [45]
 293   );
 294
 295 our %DeadBits = (
 296     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..52]
 297     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [29]
 298     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [30]
 299     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 300     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 301     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
 302     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 303     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [31]
 304     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 305     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 306     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02", # [51,52]
 307     'experimental:lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [52]
 308     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 309     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [47]
 310     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [46]
 311     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
 312     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [24]
 313     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 314     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 315     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [25]
 316     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 317     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 318     'non_unicode'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [48]
 319     'nonchar'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [49]
 320     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 321     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 322     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 323     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
 324     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [32]
 325     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 326     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
 327     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [33]
 328     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [34]
 329     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [35]
 330     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [36]
 331     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
 332     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
 333     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
 334     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [37]
 335     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [38]
 336     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00", # [21..25]
 337     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [26]
 338     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [27]
 339     'surrogate'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [50]
 340     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00", # [28..38,47]
 341     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [39]
 342     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [40]
 343     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [41]
 344     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 345     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [42]
 346     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [43]
 347     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00", # [44,48..50]
 348     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [45]
 349   );
 350
 351 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
 352 $DEFAULT  = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x01", # [2,52,4,22,23,25]
 353 $LAST_BIT = 106 ;
 354 $BYTES    = 14 ;
 355
 356 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 357
 358 sub Croaker
 359 {
 360     require Carp; # this initializes %CarpInternal
 361     local $Carp::CarpInternal{'warnings'};
 362     delete $Carp::CarpInternal{'warnings'};
 363     Carp::croak(@_);
 364 }
 365
 366 sub _bits {
 367     my $mask = shift ;
 368     my $catmask ;
 369     my $fatal = 0 ;
 370     my $no_fatal = 0 ;
 371
 372     foreach my $word ( @_ ) {
 373         if ($word eq 'FATAL') {
 374             $fatal = 1;
 375             $no_fatal = 0;
 376         }
 377         elsif ($word eq 'NONFATAL') {
 378             $fatal = 0;
 379             $no_fatal = 1;
 380         }
 381         elsif ($catmask = $Bits{$word}) {
 382             $mask |= $catmask ;
 383             $mask |= $DeadBits{$word} if $fatal ;
 384             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 385         }
 386         else
 387           { Croaker("Unknown warnings category '$word'")}
 388     }
 389
 390     return $mask ;
 391 }
 392
 393 sub bits
 394 {
 395     # called from B::Deparse.pm
 396     push @_, 'all' unless @_ ;
 397     return _bits(undef, @_) ;
 398 }
 399
 400 sub import
 401 {
 402     shift;
 403
 404     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 405
 406     if (vec($mask, $Offsets{'all'}, 1)) {
 407         $mask |= $Bits{'all'} ;
 408         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 409     }
 410
 411     # Empty @_ is equivalent to @_ = 'all' ;
 412     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
 413 }
 414
 415 sub unimport
 416 {
 417     shift;
 418
 419     my $catmask ;
 420     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 421
 422     if (vec($mask, $Offsets{'all'}, 1)) {
 423         $mask |= $Bits{'all'} ;
 424         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 425     }
 426
 427     push @_, 'all' unless @_;
 428
 429     foreach my $word ( @_ ) {
 430         if ($word eq 'FATAL') {
 431             next;
 432         }
 433         elsif ($catmask = $Bits{$word}) {
 434             $mask &= ~($catmask | $DeadBits{$word} | $All);
 435         }
 436         else
 437           { Croaker("Unknown warnings category '$word'")}
 438     }
 439
 440     ${^WARNING_BITS} = $mask ;
 441 }
 442
 443 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 444
 445 sub MESSAGE () { 4 };
 446 sub FATAL () { 2 };
 447 sub NORMAL () { 1 };
 448
 449 sub __chk
 450 {
 451     my $category ;
 452     my $offset ;
 453     my $isobj = 0 ;
 454     my $wanted = shift;
 455     my $has_message = $wanted & MESSAGE;
 456
 457     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
 458         my $sub = (caller 1)[3];
 459         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
 460         Croaker("Usage: $sub($syntax)");
 461     }
 462
 463     my $message = pop if $has_message;
 464
 465     if (@_) {
 466         # check the category supplied.
 467         $category = shift ;
 468         if (my $type = ref $category) {
 469             Croaker("not an object")
 470                 if exists $builtin_type{$type};
 471             $category = $type;
 472             $isobj = 1 ;
 473         }
 474         $offset = $Offsets{$category};
 475         Croaker("Unknown warnings category '$category'")
 476             unless defined $offset;
 477     }
 478     else {
 479         $category = (caller(1))[0] ;
 480         $offset = $Offsets{$category};
 481         Croaker("package '$category' not registered for warnings")
 482             unless defined $offset ;
 483     }
 484
 485     my $i;
 486
 487     if ($isobj) {
 488         my $pkg;
 489         $i = 2;
 490         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 491             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 492         }
 493         $i -= 2 ;
 494     }
 495     else {
 496         $i = _error_loc(); # see where Carp will allocate the error
 497     }
 498
 499     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
 500     # explicitly returns undef.
 501     my(@callers_bitmask) = (caller($i))[9] ;
 502     my $callers_bitmask =
 503          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
 504
 505     my @results;
 506     foreach my $type (FATAL, NORMAL) {
 507         next unless $wanted & $type;
 508
 509         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
 510                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
 511     }
 512
 513     # &enabled and &fatal_enabled
 514     return $results[0] unless $has_message;
 515
 516     # &warnif, and the category is neither enabled as warning nor as fatal
 517     return if $wanted == (NORMAL | FATAL | MESSAGE)
 518         && !($results[0] || $results[1]);
 519
 520     require Carp;
 521     Carp::croak($message) if $results[0];
 522     # will always get here for &warn. will only get here for &warnif if the
 523     # category is enabled
 524     Carp::carp($message);
 525 }
 526
 527 sub _mkMask
 528 {
 529     my ($bit) = @_;
 530     my $mask = "";
 531
 532     vec($mask, $bit, 1) = 1;
 533     return $mask;
 534 }
 535
 536 sub register_categories
 537 {
 538     my @names = @_;
 539
 540     for my $name (@names) {
 541         if (! defined $Bits{$name}) {
 542             $Bits{$name}     = _mkMask($LAST_BIT);
 543             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
 544             $Offsets{$name}  = $LAST_BIT ++;
 545             foreach my $k (keys %Bits) {
 546                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
 547             }
 548             $DeadBits{$name} = _mkMask($LAST_BIT);
 549             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
 550         }
 551     }
 552 }
 553
 554 sub _error_loc {
 555     require Carp;
 556     goto &Carp::short_error_loc; # don't introduce another stack frame
 557 }
 558
 559 sub enabled
 560 {
 561     return __chk(NORMAL, @_);
 562 }
 563
 564 sub fatal_enabled
 565 {
 566     return __chk(FATAL, @_);
 567 }
 568
 569 sub warn
 570 {
 571     return __chk(FATAL | MESSAGE, @_);
 572 }
 573
 574 sub warnif
 575 {
 576     return __chk(NORMAL | FATAL | MESSAGE, @_);
 577 }
 578
 579 # These are not part of any public interface, so we can delete them to save
 580 # space.
 581 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
 582
 583 1;
 584
 585 # ex: set ro: