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.03';
  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 use Carp ();
 135
 136 our %Offsets : unique = (
 137
 138     # Warnings Categories added in Perl 5.008
 139
 140     'all'               => 0,
 141     'closure'           => 2,
 142     'deprecated'        => 4,
 143     'exiting'           => 6,
 144     'glob'              => 8,
 145     'io'                => 10,
 146     'closed'            => 12,
 147     'exec'              => 14,
 148     'layer'             => 16,
 149     'newline'           => 18,
 150     'pipe'              => 20,
 151     'unopened'          => 22,
 152     'misc'              => 24,
 153     'numeric'           => 26,
 154     'once'              => 28,
 155     'overflow'          => 30,
 156     'pack'              => 32,
 157     'portable'          => 34,
 158     'recursion'         => 36,
 159     'redefine'          => 38,
 160     'regexp'            => 40,
 161     'severe'            => 42,
 162     'debugging'         => 44,
 163     'inplace'           => 46,
 164     'internal'          => 48,
 165     'malloc'            => 50,
 166     'signal'            => 52,
 167     'substr'            => 54,
 168     'syntax'            => 56,
 169     'ambiguous'         => 58,
 170     'bareword'          => 60,
 171     'digit'             => 62,
 172     'parenthesis'       => 64,
 173     'precedence'        => 66,
 174     'printf'            => 68,
 175     'prototype'         => 70,
 176     'qw'                => 72,
 177     'reserved'          => 74,
 178     'semicolon'         => 76,
 179     'taint'             => 78,
 180     'threads'           => 80,
 181     'uninitialized'     => 82,
 182     'unpack'            => 84,
 183     'untie'             => 86,
 184     'utf8'              => 88,
 185     'void'              => 90,
 186     'y2k'               => 92,
 187
 188     # Warnings Categories added in Perl 5.009
 189
 190     'assertions'        => 94,
 191   );
 192
 193 our %Bits : unique = (
 194     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
 195     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
 196     'assertions'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
 197     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
 198     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 199     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 200     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
 201     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 202     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
 203     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 204     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 205     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 206     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
 207     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
 208     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 209     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 210     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
 211     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 212     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 213     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 214     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 215     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 216     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
 217     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
 218     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 219     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
 220     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
 221     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
 222     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
 223     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
 224     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
 225     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
 226     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
 227     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
 228     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
 229     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
 230     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
 231     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
 232     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
 233     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
 234     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
 235     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
 236     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 237     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
 238     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 239     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 240     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 241     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
 242   );
 243
 244 our %DeadBits : unique = (
 245     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
 246     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
 247     'assertions'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
 248     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
 249     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 250     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 251     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
 252     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 253     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
 254     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 255     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 256     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 257     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
 258     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
 259     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 260     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 261     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
 262     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 263     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 264     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 265     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 266     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 267     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
 268     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
 269     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 270     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
 271     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
 272     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
 273     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
 274     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
 275     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
 276     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
 277     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
 278     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
 279     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
 280     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
 281     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
 282     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
 283     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
 284     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
 285     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
 286     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
 287     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 288     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
 289     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
 290     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
 291     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
 292     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
 293   );
 294
 295 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
 296 $LAST_BIT = 96 ;
 297 $BYTES    = 12 ;
 298
 299 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 300
 301 sub Croaker
 302 {
 303     delete $Carp::CarpInternal{'warnings'};
 304     Carp::croak(@_);
 305 }
 306
 307 sub bits
 308 {
 309     # called from B::Deparse.pm
 310
 311     push @_, 'all' unless @_;
 312
 313     my $mask;
 314     my $catmask ;
 315     my $fatal = 0 ;
 316     my $no_fatal = 0 ;
 317
 318     foreach my $word ( @_ ) {
 319         if ($word eq 'FATAL') {
 320             $fatal = 1;
 321             $no_fatal = 0;
 322         }
 323         elsif ($word eq 'NONFATAL') {
 324             $fatal = 0;
 325             $no_fatal = 1;
 326         }
 327         elsif ($catmask = $Bits{$word}) {
 328             $mask |= $catmask ;
 329             $mask |= $DeadBits{$word} if $fatal ;
 330             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 331         }
 332         else
 333           { Croaker("Unknown warnings category '$word'")}
 334     }
 335
 336     return $mask ;
 337 }
 338
 339 sub import
 340 {
 341     shift;
 342
 343     my $catmask ;
 344     my $fatal = 0 ;
 345     my $no_fatal = 0 ;
 346
 347     my $mask = ${^WARNING_BITS} ;
 348
 349     if (vec($mask, $Offsets{'all'}, 1)) {
 350         $mask |= $Bits{'all'} ;
 351         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 352     }
 353
 354     push @_, 'all' unless @_;
 355
 356     foreach my $word ( @_ ) {
 357         if ($word eq 'FATAL') {
 358             $fatal = 1;
 359             $no_fatal = 0;
 360         }
 361         elsif ($word eq 'NONFATAL') {
 362             $fatal = 0;
 363             $no_fatal = 1;
 364         }
 365         elsif ($catmask = $Bits{$word}) {
 366             $mask |= $catmask ;
 367             $mask |= $DeadBits{$word} if $fatal ;
 368             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 369         }
 370         else
 371           { Croaker("Unknown warnings category '$word'")}
 372     }
 373
 374     ${^WARNING_BITS} = $mask ;
 375 }
 376
 377 sub unimport
 378 {
 379     shift;
 380
 381     my $catmask ;
 382     my $mask = ${^WARNING_BITS} ;
 383
 384     if (vec($mask, $Offsets{'all'}, 1)) {
 385         $mask |= $Bits{'all'} ;
 386         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 387     }
 388
 389     push @_, 'all' unless @_;
 390
 391     foreach my $word ( @_ ) {
 392         if ($word eq 'FATAL') {
 393             next;
 394         }
 395         elsif ($catmask = $Bits{$word}) {
 396             $mask &= ~($catmask | $DeadBits{$word} | $All);
 397         }
 398         else
 399           { Croaker("Unknown warnings category '$word'")}
 400     }
 401
 402     ${^WARNING_BITS} = $mask ;
 403 }
 404
 405 sub __chk
 406 {
 407     my $category ;
 408     my $offset ;
 409     my $isobj = 0 ;
 410
 411     if (@_) {
 412         # check the category supplied.
 413         $category = shift ;
 414         if (ref $category) {
 415             Croaker ("not an object")
 416                 if $category !~ /^([^=]+)=/ ;
 417             $category = $1 ;
 418             $isobj = 1 ;
 419         }
 420         $offset = $Offsets{$category};
 421         Croaker("Unknown warnings category '$category'")
 422             unless defined $offset;
 423     }
 424     else {
 425         $category = (caller(1))[0] ;
 426         $offset = $Offsets{$category};
 427         Croaker("package '$category' not registered for warnings")
 428             unless defined $offset ;
 429     }
 430
 431     my $this_pkg = (caller(1))[0] ;
 432     my $i = 2 ;
 433     my $pkg ;
 434
 435     if ($isobj) {
 436         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 437             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 438         }
 439         $i -= 2 ;
 440     }
 441     else {
 442         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 443             last if $pkg ne $this_pkg ;
 444         }
 445         $i = 2
 446             if !$pkg || $pkg eq $this_pkg ;
 447     }
 448
 449     my $callers_bitmask = (caller($i))[9] ;
 450     return ($callers_bitmask, $offset, $i) ;
 451 }
 452
 453 sub enabled
 454 {
 455     Croaker("Usage: warnings::enabled([category])")
 456         unless @_ == 1 || @_ == 0 ;
 457
 458     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 459
 460     return 0 unless defined $callers_bitmask ;
 461     return vec($callers_bitmask, $offset, 1) ||
 462            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 463 }
 464
 465
 466 sub warn
 467 {
 468     Croaker("Usage: warnings::warn([category,] 'message')")
 469         unless @_ == 2 || @_ == 1 ;
 470
 471     my $message = pop ;
 472     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 473     Carp::croak($message)
 474         if vec($callers_bitmask, $offset+1, 1) ||
 475            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 476     Carp::carp($message) ;
 477 }
 478
 479 sub warnif
 480 {
 481     Croaker("Usage: warnings::warnif([category,] 'message')")
 482         unless @_ == 2 || @_ == 1 ;
 483
 484     my $message = pop ;
 485     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 486
 487     return
 488         unless defined $callers_bitmask &&
 489                 (vec($callers_bitmask, $offset, 1) ||
 490                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 491
 492     Carp::croak($message)
 493         if vec($callers_bitmask, $offset+1, 1) ||
 494            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 495
 496     Carp::carp($message) ;
 497 }
 498
 499 1;