lib/warnings.pm

   1 # -*- buffer-read-only: t -*-
   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
 185     # Warnings Categories added in Perl 5.009
 186
 187     'assertions'        => 92,
 188   );
 189
 190 our %Bits = (
 191     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
 192     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
 193     'assertions'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
 194     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
 195     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 196     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 197     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
 198     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 199     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
 200     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 201     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 202     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 203     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
 204     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
 205     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 206     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 207     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
 208     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 209     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 210     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 211     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 212     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 213     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
 214     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
 215     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 216     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
 217     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
 218     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
 219     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
 220     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
 221     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
 222     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
 223     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
 224     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
 225     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
 226     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
 227     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
 228     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
 229     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
 230     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
 231     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
 232     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
 233     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 234     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
 235     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 236     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 237     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 238   );
 239
 240 our %DeadBits = (
 241     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
 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\x20", # [46]
 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   );
 289
 290 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
 291 $LAST_BIT = 94 ;
 292 $BYTES    = 12 ;
 293
 294 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 295
 296 sub Croaker
 297 {
 298     require Carp::Heavy; # this initializes %CarpInternal
 299     delete $Carp::CarpInternal{'warnings'};
 300     Carp::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 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 402
 403 sub __chk
 404 {
 405     my $category ;
 406     my $offset ;
 407     my $isobj = 0 ;
 408
 409     if (@_) {
 410         # check the category supplied.
 411         $category = shift ;
 412         if (my $type = ref $category) {
 413             Croaker("not an object")
 414                 if exists $builtin_type{$type};
 415             $category = $type;
 416             $isobj = 1 ;
 417         }
 418         $offset = $Offsets{$category};
 419         Croaker("Unknown warnings category '$category'")
 420             unless defined $offset;
 421     }
 422     else {
 423         $category = (caller(1))[0] ;
 424         $offset = $Offsets{$category};
 425         Croaker("package '$category' not registered for warnings")
 426             unless defined $offset ;
 427     }
 428
 429     my $this_pkg = (caller(1))[0] ;
 430     my $i = 2 ;
 431     my $pkg ;
 432
 433     if ($isobj) {
 434         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 435             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 436         }
 437         $i -= 2 ;
 438     }
 439     else {
 440         $i = _error_loc(); # see where Carp will allocate the error
 441     }
 442
 443     my $callers_bitmask = (caller($i))[9] ;
 444     return ($callers_bitmask, $offset, $i) ;
 445 }
 446
 447 sub _error_loc {
 448     require Carp::Heavy;
 449     goto &Carp::short_error_loc; # don't introduce another stack frame
 450 }
 451
 452 sub enabled
 453 {
 454     Croaker("Usage: warnings::enabled([category])")
 455         unless @_ == 1 || @_ == 0 ;
 456
 457     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 458
 459     return 0 unless defined $callers_bitmask ;
 460     return vec($callers_bitmask, $offset, 1) ||
 461            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 462 }
 463
 464
 465 sub warn
 466 {
 467     Croaker("Usage: warnings::warn([category,] 'message')")
 468         unless @_ == 2 || @_ == 1 ;
 469
 470     my $message = pop ;
 471     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 472     require Carp;
 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     require Carp;
 493     Carp::croak($message)
 494         if vec($callers_bitmask, $offset+1, 1) ||
 495            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 496
 497     Carp::carp($message) ;
 498 }
 499
 500 1;
 501 # ex: set ro: