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
 133     # Warnings Categories added in Perl 5.008
 134
 135     'all'               => 0,
 136     'closure'           => 2,
 137     'deprecated'        => 4,
 138     'exiting'           => 6,
 139     'glob'              => 8,
 140     'io'                => 10,
 141     'closed'            => 12,
 142     'exec'              => 14,
 143     'layer'             => 16,
 144     'newline'           => 18,
 145     'pipe'              => 20,
 146     'unopened'          => 22,
 147     'misc'              => 24,
 148     'numeric'           => 26,
 149     'once'              => 28,
 150     'overflow'          => 30,
 151     'pack'              => 32,
 152     'portable'          => 34,
 153     'recursion'         => 36,
 154     'redefine'          => 38,
 155     'regexp'            => 40,
 156     'severe'            => 42,
 157     'debugging'         => 44,
 158     'inplace'           => 46,
 159     'internal'          => 48,
 160     'malloc'            => 50,
 161     'signal'            => 52,
 162     'substr'            => 54,
 163     'syntax'            => 56,
 164     'ambiguous'         => 58,
 165     'bareword'          => 60,
 166     'digit'             => 62,
 167     'parenthesis'       => 64,
 168     'precedence'        => 66,
 169     'printf'            => 68,
 170     'prototype'         => 70,
 171     'qw'                => 72,
 172     'reserved'          => 74,
 173     'semicolon'         => 76,
 174     'taint'             => 78,
 175     'uninitialized'     => 80,
 176     'unpack'            => 82,
 177     'untie'             => 84,
 178     'utf8'              => 86,
 179     'void'              => 88,
 180     'y2k'               => 90,
 181   );
 182
 183 %Bits = (
 184     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", # [0..45]
 185     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
 186     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
 187     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 188     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 189     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
 190     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 191     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
 192     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 193     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 194     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 195     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
 196     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
 197     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 198     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 199     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
 200     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 201     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 202     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 203     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 204     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 205     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
 206     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
 207     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 208     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
 209     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
 210     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
 211     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
 212     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
 213     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
 214     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
 215     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
 216     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
 217     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
 218     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
 219     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
 220     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
 221     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
 222     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
 223     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
 224     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 225     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
 226     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
 227     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 228     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 229     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 230   );
 231
 232 %DeadBits = (
 233     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x0a", # [0..45]
 234     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
 235     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
 236     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 237     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 238     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
 239     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 240     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
 241     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 242     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 243     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 244     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
 245     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
 246     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
 247     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 248     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
 249     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 250     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 251     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 252     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 253     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 254     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
 255     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
 256     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 257     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
 258     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
 259     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
 260     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
 261     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
 262     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
 263     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
 264     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
 265     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
 266     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
 267     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
 268     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
 269     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
 270     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
 271     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
 272     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
 273     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 274     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
 275     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
 276     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
 277     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
 278     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
 279   );
 280
 281 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
 282 $LAST_BIT = 92 ;
 283 $BYTES    = 12 ;
 284
 285 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 286
 287 sub Croaker
 288 {
 289     delete $Carp::CarpInternal{'warnings'};
 290     croak @_ ;
 291 }
 292
 293 sub bits {
 294     my $mask ;
 295     my $catmask ;
 296     my $fatal = 0 ;
 297     foreach my $word (@_) {
 298         if  ($word eq 'FATAL') {
 299             $fatal = 1;
 300         }
 301         elsif ($catmask = $Bits{$word}) {
 302             $mask |= $catmask ;
 303             $mask |= $DeadBits{$word} if $fatal ;
 304         }
 305         else
 306           { Croaker("Unknown warnings category '$word'")}
 307     }
 308
 309     return $mask ;
 310 }
 311
 312 sub import {
 313     shift;
 314     my $mask = ${^WARNING_BITS} ;
 315     if (vec($mask, $Offsets{'all'}, 1)) {
 316         $mask |= $Bits{'all'} ;
 317         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 318     }
 319     ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
 320 }
 321
 322 sub unimport {
 323     shift;
 324     my $mask = ${^WARNING_BITS} ;
 325     if (vec($mask, $Offsets{'all'}, 1)) {
 326         $mask |= $Bits{'all'} ;
 327         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 328     }
 329     ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
 330 }
 331
 332 sub __chk
 333 {
 334     my $category ;
 335     my $offset ;
 336     my $isobj = 0 ;
 337
 338     if (@_) {
 339         # check the category supplied.
 340         $category = shift ;
 341         if (ref $category) {
 342             Croaker ("not an object")
 343                 if $category !~ /^([^=]+)=/ ;
 344             $category = $1 ;
 345             $isobj = 1 ;
 346         }
 347         $offset = $Offsets{$category};
 348         Croaker("Unknown warnings category '$category'")
 349             unless defined $offset;
 350     }
 351     else {
 352         $category = (caller(1))[0] ;
 353         $offset = $Offsets{$category};
 354         Croaker("package '$category' not registered for warnings")
 355             unless defined $offset ;
 356     }
 357
 358     my $this_pkg = (caller(1))[0] ;
 359     my $i = 2 ;
 360     my $pkg ;
 361
 362     if ($isobj) {
 363         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 364             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 365         }
 366         $i -= 2 ;
 367     }
 368     else {
 369         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 370             last if $pkg ne $this_pkg ;
 371         }
 372         $i = 2
 373             if !$pkg || $pkg eq $this_pkg ;
 374     }
 375
 376     my $callers_bitmask = (caller($i))[9] ;
 377     return ($callers_bitmask, $offset, $i) ;
 378 }
 379
 380 sub enabled
 381 {
 382     Croaker("Usage: warnings::enabled([category])")
 383         unless @_ == 1 || @_ == 0 ;
 384
 385     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 386
 387     return 0 unless defined $callers_bitmask ;
 388     return vec($callers_bitmask, $offset, 1) ||
 389            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 390 }
 391
 392
 393 sub warn
 394 {
 395     Croaker("Usage: warnings::warn([category,] 'message')")
 396         unless @_ == 2 || @_ == 1 ;
 397
 398     my $message = pop ;
 399     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 400     croak($message)
 401         if vec($callers_bitmask, $offset+1, 1) ||
 402            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 403     carp($message) ;
 404 }
 405
 406 sub warnif
 407 {
 408     Croaker("Usage: warnings::warnif([category,] 'message')")
 409         unless @_ == 2 || @_ == 1 ;
 410
 411     my $message = pop ;
 412     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 413
 414     return
 415         unless defined $callers_bitmask &&
 416                 (vec($callers_bitmask, $offset, 1) ||
 417                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 418
 419     croak($message)
 420         if vec($callers_bitmask, $offset+1, 1) ||
 421            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 422
 423     carp($message) ;
 424 }
 425
 426 1;