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