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