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