lib/warnings.pm

   1
   2 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
   3 # This file was created by warnings.pl
   4 # Any changes made here will be lost.
   5 #
   6
   7 package warnings;
   8
   9 our $VERSION = '1.00';
  10
  11 =head1 NAME
  12
  13 warnings - Perl pragma to control optional warnings
  14
  15 =head1 SYNOPSIS
  16
  17     use warnings;
  18     no warnings;
  19
  20     use warnings "all";
  21     no warnings "all";
  22
  23     use warnings::register;
  24     if (warnings::enabled()) {
  25         warnings::warn("some warning");
  26     }
  27
  28     if (warnings::enabled("void")) {
  29         warnings::warn("void", "some warning");
  30     }
  31
  32     if (warnings::enabled($object)) {
  33         warnings::warn($object, "some warning");
  34     }
  35
  36     warnings::warnif("some warning");
  37     warnings::warnif("void", "some warning");
  38     warnings::warnif($object, "some warning");
  39
  40 =head1 DESCRIPTION
  41
  42 If no import list is supplied, all possible warnings are either enabled
  43 or disabled.
  44
  45 A number of functions are provided to assist module authors.
  46
  47 =over 4
  48
  49 =item use warnings::register
  50
  51 Creates a new warnings category with the same name as the package where
  52 the call to the pragma is used.
  53
  54 =item warnings::enabled()
  55
  56 Use the warnings category with the same name as the current package.
  57
  58 Return TRUE if that warnings category is enabled in the calling module.
  59 Otherwise returns FALSE.
  60
  61 =item warnings::enabled($category)
  62
  63 Return TRUE if the warnings category, C<$category>, is enabled in the
  64 calling module.
  65 Otherwise returns FALSE.
  66
  67 =item warnings::enabled($object)
  68
  69 Use the name of the class for the object reference, C<$object>, as the
  70 warnings category.
  71
  72 Return TRUE if that warnings category is enabled in the first scope
  73 where the object is used.
  74 Otherwise returns FALSE.
  75
  76 =item warnings::warn($message)
  77
  78 Print C<$message> to STDERR.
  79
  80 Use the warnings category with the same name as the current package.
  81
  82 If that warnings category has been set to "FATAL" in the calling module
  83 then die. Otherwise return.
  84
  85 =item warnings::warn($category, $message)
  86
  87 Print C<$message> to STDERR.
  88
  89 If the warnings category, C<$category>, has been set to "FATAL" in the
  90 calling module then die. Otherwise return.
  91
  92 =item warnings::warn($object, $message)
  93
  94 Print C<$message> to STDERR.
  95
  96 Use the name of the class for the object reference, C<$object>, as the
  97 warnings category.
  98
  99 If that warnings category has been set to "FATAL" in the scope where C<$object>
 100 is first used then die. Otherwise return.
 101
 102
 103 =item warnings::warnif($message)
 104
 105 Equivalent to:
 106
 107     if (warnings::enabled())
 108       { warnings::warn($message) }
 109
 110 =item warnings::warnif($category, $message)
 111
 112 Equivalent to:
 113
 114     if (warnings::enabled($category))
 115       { warnings::warn($category, $message) }
 116
 117 =item warnings::warnif($object, $message)
 118
 119 Equivalent to:
 120
 121     if (warnings::enabled($object))
 122       { warnings::warn($object, $message) }
 123
 124 =back
 125
 126 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 127
 128 =cut
 129
 130 use Carp ;
 131
 132 %Offsets = (
 133
 134     # Warnings Categories added in Perl 5.008
 135
 136     'all'               => 0,
 137     'closure'           => 2,
 138     'deprecated'        => 4,
 139     'exiting'           => 6,
 140     'glob'              => 8,
 141     'io'                => 10,
 142     'closed'            => 12,
 143     'exec'              => 14,
 144     'layer'             => 16,
 145     'newline'           => 18,
 146     'pipe'              => 20,
 147     'unopened'          => 22,
 148     'misc'              => 24,
 149     'numeric'           => 26,
 150     'once'              => 28,
 151     'overflow'          => 30,
 152     'pack'              => 32,
 153     'portable'          => 34,
 154     'recursion'         => 36,
 155     'redefine'          => 38,
 156     'regexp'            => 40,
 157     'severe'            => 42,
 158     'debugging'         => 44,
 159     'inplace'           => 46,
 160     'internal'          => 48,
 161     'malloc'            => 50,
 162     'signal'            => 52,
 163     'substr'            => 54,
 164     'syntax'            => 56,
 165     'ambiguous'         => 58,
 166     'bareword'          => 60,
 167     'digit'             => 62,
 168     'parenthesis'       => 64,
 169     'precedence'        => 66,
 170     'printf'            => 68,
 171     'prototype'         => 70,
 172     'qw'                => 72,
 173     'reserved'          => 74,
 174     'semicolon'         => 76,
 175     'taint'             => 78,
 176     'threads'           => 80,
 177     'uninitialized'     => 82,
 178     'unpack'            => 84,
 179     'untie'             => 86,
 180     'utf8'              => 88,
 181     'void'              => 90,
 182     'y2k'               => 92,
 183
 184     # Warnings Categories added in Perl 5.009
 185
 186     'assertions'        => 94,
 187   );
 188
 189 %Bits = (
 190     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
 191     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
 192     'assertions'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
 193     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
 194     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 195     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 196     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
 197     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 198     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
 199     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 200     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 201     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 202     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
 203     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
 204     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 205     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 206     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
 207     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 208     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 209     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 210     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 211     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 212     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
 213     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
 214     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 215     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
 216     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
 217     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
 218     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
 219     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
 220     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
 221     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
 222     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
 223     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
 224     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
 225     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
 226     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
 227     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
 228     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
 229     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
 230     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
 231     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
 232     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 233     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
 234     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 235     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 236     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 237     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
 238   );
 239
 240 %DeadBits = (
 241     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
 242     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
 243     'assertions'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
 244     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
 245     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 246     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 247     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
 248     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 249     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
 250     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 251     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 252     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 253     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
 254     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
 255     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 256     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 257     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
 258     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 259     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 260     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 261     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 262     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 263     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
 264     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
 265     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 266     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
 267     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
 268     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
 269     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
 270     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
 271     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
 272     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
 273     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
 274     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
 275     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
 276     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
 277     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
 278     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
 279     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
 280     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
 281     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
 282     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
 283     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 284     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
 285     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
 286     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
 287     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
 288     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
 289   );
 290
 291 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
 292 $LAST_BIT = 96 ;
 293 $BYTES    = 12 ;
 294
 295 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 296
 297 sub Croaker
 298 {
 299     delete $Carp::CarpInternal{'warnings'};
 300     croak(@_);
 301 }
 302
 303 sub bits
 304 {
 305     # called from B::Deparse.pm
 306
 307     push @_, 'all' unless @_;
 308
 309     my $mask;
 310     my $catmask ;
 311     my $fatal = 0 ;
 312     my $no_fatal = 0 ;
 313
 314     foreach my $word ( @_ ) {
 315         if ($word eq 'FATAL') {
 316             $fatal = 1;
 317             $no_fatal = 0;
 318         }
 319         elsif ($word eq 'NONFATAL') {
 320             $fatal = 0;
 321             $no_fatal = 1;
 322         }
 323         elsif ($catmask = $Bits{$word}) {
 324             $mask |= $catmask ;
 325             $mask |= $DeadBits{$word} if $fatal ;
 326             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 327         }
 328         else
 329           { Croaker("Unknown warnings category '$word'")}
 330     }
 331
 332     return $mask ;
 333 }
 334
 335 sub import
 336 {
 337     shift;
 338
 339     my $catmask ;
 340     my $fatal = 0 ;
 341     my $no_fatal = 0 ;
 342
 343     my $mask = ${^WARNING_BITS} ;
 344
 345     if (vec($mask, $Offsets{'all'}, 1)) {
 346         $mask |= $Bits{'all'} ;
 347         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 348     }
 349
 350     push @_, 'all' unless @_;
 351
 352     foreach my $word ( @_ ) {
 353         if ($word eq 'FATAL') {
 354             $fatal = 1;
 355             $no_fatal = 0;
 356         }
 357         elsif ($word eq 'NONFATAL') {
 358             $fatal = 0;
 359             $no_fatal = 1;
 360         }
 361         elsif ($catmask = $Bits{$word}) {
 362             $mask |= $catmask ;
 363             $mask |= $DeadBits{$word} if $fatal ;
 364             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 365         }
 366         else
 367           { Croaker("Unknown warnings category '$word'")}
 368     }
 369
 370     ${^WARNING_BITS} = $mask ;
 371 }
 372
 373 sub unimport
 374 {
 375     shift;
 376
 377     my $catmask ;
 378     my $mask = ${^WARNING_BITS} ;
 379
 380     if (vec($mask, $Offsets{'all'}, 1)) {
 381         $mask |= $Bits{'all'} ;
 382         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 383     }
 384
 385     push @_, 'all' unless @_;
 386
 387     foreach my $word ( @_ ) {
 388         if ($word eq 'FATAL') {
 389             next;
 390         }
 391         elsif ($catmask = $Bits{$word}) {
 392             $mask &= ~($catmask | $DeadBits{$word} | $All);
 393         }
 394         else
 395           { Croaker("Unknown warnings category '$word'")}
 396     }
 397
 398     ${^WARNING_BITS} = $mask ;
 399 }
 400
 401 sub __chk
 402 {
 403     my $category ;
 404     my $offset ;
 405     my $isobj = 0 ;
 406
 407     if (@_) {
 408         # check the category supplied.
 409         $category = shift ;
 410         if (ref $category) {
 411             Croaker ("not an object")
 412                 if $category !~ /^([^=]+)=/ ;
 413             $category = $1 ;
 414             $isobj = 1 ;
 415         }
 416         $offset = $Offsets{$category};
 417         Croaker("Unknown warnings category '$category'")
 418             unless defined $offset;
 419     }
 420     else {
 421         $category = (caller(1))[0] ;
 422         $offset = $Offsets{$category};
 423         Croaker("package '$category' not registered for warnings")
 424             unless defined $offset ;
 425     }
 426
 427     my $this_pkg = (caller(1))[0] ;
 428     my $i = 2 ;
 429     my $pkg ;
 430
 431     if ($isobj) {
 432         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 433             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 434         }
 435         $i -= 2 ;
 436     }
 437     else {
 438         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 439             last if $pkg ne $this_pkg ;
 440         }
 441         $i = 2
 442             if !$pkg || $pkg eq $this_pkg ;
 443     }
 444
 445     my $callers_bitmask = (caller($i))[9] ;
 446     return ($callers_bitmask, $offset, $i) ;
 447 }
 448
 449 sub enabled
 450 {
 451     Croaker("Usage: warnings::enabled([category])")
 452         unless @_ == 1 || @_ == 0 ;
 453
 454     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 455
 456     return 0 unless defined $callers_bitmask ;
 457     return vec($callers_bitmask, $offset, 1) ||
 458            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 459 }
 460
 461
 462 sub warn
 463 {
 464     Croaker("Usage: warnings::warn([category,] 'message')")
 465         unless @_ == 2 || @_ == 1 ;
 466
 467     my $message = pop ;
 468     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 469     croak($message)
 470         if vec($callers_bitmask, $offset+1, 1) ||
 471            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 472     carp($message) ;
 473 }
 474
 475 sub warnif
 476 {
 477     Croaker("Usage: warnings::warnif([category,] 'message')")
 478         unless @_ == 2 || @_ == 1 ;
 479
 480     my $message = pop ;
 481     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 482
 483     return
 484         unless defined $callers_bitmask &&
 485                 (vec($callers_bitmask, $offset, 1) ||
 486                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 487
 488     croak($message)
 489         if vec($callers_bitmask, $offset+1, 1) ||
 490            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 491
 492     carp($message) ;
 493 }
 494
 495 1;