lib/warnings.pm

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