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     my $mask ;
 299     my $catmask ;
 300     my $fatal = 0 ;
 301     foreach my $word (@_) {
 302         if  ($word eq 'FATAL') {
 303             $fatal = 1;
 304         }
 305         elsif ($catmask = $Bits{$word}) {
 306             $mask |= $catmask ;
 307             $mask |= $DeadBits{$word} if $fatal ;
 308         }
 309         else
 310           { Croaker("Unknown warnings category '$word'")}
 311     }
 312
 313     return $mask ;
 314 }
 315
 316 sub import {
 317     shift;
 318     my $mask = ${^WARNING_BITS} ;
 319     if (vec($mask, $Offsets{'all'}, 1)) {
 320         $mask |= $Bits{'all'} ;
 321         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 322     }
 323     ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
 324 }
 325
 326 sub unimport {
 327     shift;
 328     my $mask = ${^WARNING_BITS} ;
 329     if (vec($mask, $Offsets{'all'}, 1)) {
 330         $mask |= $Bits{'all'} ;
 331         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 332     }
 333     ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
 334 }
 335
 336 sub __chk
 337 {
 338     my $category ;
 339     my $offset ;
 340     my $isobj = 0 ;
 341
 342     if (@_) {
 343         # check the category supplied.
 344         $category = shift ;
 345         if (ref $category) {
 346             Croaker ("not an object")
 347                 if $category !~ /^([^=]+)=/ ;
 348             $category = $1 ;
 349             $isobj = 1 ;
 350         }
 351         $offset = $Offsets{$category};
 352         Croaker("Unknown warnings category '$category'")
 353             unless defined $offset;
 354     }
 355     else {
 356         $category = (caller(1))[0] ;
 357         $offset = $Offsets{$category};
 358         Croaker("package '$category' not registered for warnings")
 359             unless defined $offset ;
 360     }
 361
 362     my $this_pkg = (caller(1))[0] ;
 363     my $i = 2 ;
 364     my $pkg ;
 365
 366     if ($isobj) {
 367         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 368             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 369         }
 370         $i -= 2 ;
 371     }
 372     else {
 373         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 374             last if $pkg ne $this_pkg ;
 375         }
 376         $i = 2
 377             if !$pkg || $pkg eq $this_pkg ;
 378     }
 379
 380     my $callers_bitmask = (caller($i))[9] ;
 381     return ($callers_bitmask, $offset, $i) ;
 382 }
 383
 384 sub enabled
 385 {
 386     Croaker("Usage: warnings::enabled([category])")
 387         unless @_ == 1 || @_ == 0 ;
 388
 389     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 390
 391     return 0 unless defined $callers_bitmask ;
 392     return vec($callers_bitmask, $offset, 1) ||
 393            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 394 }
 395
 396
 397 sub warn
 398 {
 399     Croaker("Usage: warnings::warn([category,] 'message')")
 400         unless @_ == 2 || @_ == 1 ;
 401
 402     my $message = pop ;
 403     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 404     croak($message)
 405         if vec($callers_bitmask, $offset+1, 1) ||
 406            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 407     carp($message) ;
 408 }
 409
 410 sub warnif
 411 {
 412     Croaker("Usage: warnings::warnif([category,] 'message')")
 413         unless @_ == 2 || @_ == 1 ;
 414
 415     my $message = pop ;
 416     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 417
 418     return
 419         unless defined $callers_bitmask &&
 420                 (vec($callers_bitmask, $offset, 1) ||
 421                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 422
 423     croak($message)
 424         if vec($callers_bitmask, $offset+1, 1) ||
 425            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 426
 427     carp($message) ;
 428 }
 429
 430 1;