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