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     local $Carp::CarpInternal{'warnings'};
 300     delete $Carp::CarpInternal{'warnings'};
 301     Carp::croak(@_);
 302 }
 303
 304 sub bits
 305 {
 306     # called from B::Deparse.pm
 307
 308     push @_, 'all' unless @_;
 309
 310     my $mask;
 311     my $catmask ;
 312     my $fatal = 0 ;
 313     my $no_fatal = 0 ;
 314
 315     foreach my $word ( @_ ) {
 316         if ($word eq 'FATAL') {
 317             $fatal = 1;
 318             $no_fatal = 0;
 319         }
 320         elsif ($word eq 'NONFATAL') {
 321             $fatal = 0;
 322             $no_fatal = 1;
 323         }
 324         elsif ($catmask = $Bits{$word}) {
 325             $mask |= $catmask ;
 326             $mask |= $DeadBits{$word} if $fatal ;
 327             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 328         }
 329         else
 330           { Croaker("Unknown warnings category '$word'")}
 331     }
 332
 333     return $mask ;
 334 }
 335
 336 sub import
 337 {
 338     shift;
 339
 340     my $catmask ;
 341     my $fatal = 0 ;
 342     my $no_fatal = 0 ;
 343
 344     my $mask = ${^WARNING_BITS} ;
 345
 346     if (vec($mask, $Offsets{'all'}, 1)) {
 347         $mask |= $Bits{'all'} ;
 348         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 349     }
 350
 351     push @_, 'all' unless @_;
 352
 353     foreach my $word ( @_ ) {
 354         if ($word eq 'FATAL') {
 355             $fatal = 1;
 356             $no_fatal = 0;
 357         }
 358         elsif ($word eq 'NONFATAL') {
 359             $fatal = 0;
 360             $no_fatal = 1;
 361         }
 362         elsif ($catmask = $Bits{$word}) {
 363             $mask |= $catmask ;
 364             $mask |= $DeadBits{$word} if $fatal ;
 365             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 366         }
 367         else
 368           { Croaker("Unknown warnings category '$word'")}
 369     }
 370
 371     ${^WARNING_BITS} = $mask ;
 372 }
 373
 374 sub unimport
 375 {
 376     shift;
 377
 378     my $catmask ;
 379     my $mask = ${^WARNING_BITS} ;
 380
 381     if (vec($mask, $Offsets{'all'}, 1)) {
 382         $mask |= $Bits{'all'} ;
 383         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 384     }
 385
 386     push @_, 'all' unless @_;
 387
 388     foreach my $word ( @_ ) {
 389         if ($word eq 'FATAL') {
 390             next;
 391         }
 392         elsif ($catmask = $Bits{$word}) {
 393             $mask &= ~($catmask | $DeadBits{$word} | $All);
 394         }
 395         else
 396           { Croaker("Unknown warnings category '$word'")}
 397     }
 398
 399     ${^WARNING_BITS} = $mask ;
 400 }
 401
 402 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 403
 404 sub __chk
 405 {
 406     my $category ;
 407     my $offset ;
 408     my $isobj = 0 ;
 409
 410     if (@_) {
 411         # check the category supplied.
 412         $category = shift ;
 413         if (my $type = ref $category) {
 414             Croaker("not an object")
 415                 if exists $builtin_type{$type};
 416             $category = $type;
 417             $isobj = 1 ;
 418         }
 419         $offset = $Offsets{$category};
 420         Croaker("Unknown warnings category '$category'")
 421             unless defined $offset;
 422     }
 423     else {
 424         $category = (caller(1))[0] ;
 425         $offset = $Offsets{$category};
 426         Croaker("package '$category' not registered for warnings")
 427             unless defined $offset ;
 428     }
 429
 430     my $this_pkg = (caller(1))[0] ;
 431     my $i = 2 ;
 432     my $pkg ;
 433
 434     if ($isobj) {
 435         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 436             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 437         }
 438         $i -= 2 ;
 439     }
 440     else {
 441         $i = _error_loc(); # see where Carp will allocate the error
 442     }
 443
 444     my $callers_bitmask = (caller($i))[9] ;
 445     return ($callers_bitmask, $offset, $i) ;
 446 }
 447
 448 sub _error_loc {
 449     require Carp::Heavy;
 450     goto &Carp::short_error_loc; # don't introduce another stack frame
 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     require Carp;
 474     Carp::croak($message)
 475         if vec($callers_bitmask, $offset+1, 1) ||
 476            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 477     Carp::carp($message) ;
 478 }
 479
 480 sub warnif
 481 {
 482     Croaker("Usage: warnings::warnif([category,] 'message')")
 483         unless @_ == 2 || @_ == 1 ;
 484
 485     my $message = pop ;
 486     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 487
 488     return
 489         unless defined $callers_bitmask &&
 490                 (vec($callers_bitmask, $offset, 1) ||
 491                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 492
 493     require Carp;
 494     Carp::croak($message)
 495         if vec($callers_bitmask, $offset+1, 1) ||
 496            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 497
 498     Carp::carp($message) ;
 499 }
 500
 501 1;
 502 # ex: set ro: