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     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
 307 }
 308
 309 sub unimport {
 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') | $All) ;
 317 }
 318
 319 sub __chk
 320 {
 321     my $category ;
 322     my $offset ;
 323     my $isobj = 0 ;
 324
 325     if (@_) {
 326         # check the category supplied.
 327         $category = shift ;
 328         if (ref $category) {
 329             croak ("not an object")
 330                 if $category !~ /^([^=]+)=/ ;+
 331             $category = $1 ;
 332             $isobj = 1 ;
 333         }
 334         $offset = $Offsets{$category};
 335         croak("unknown warnings category '$category'")
 336             unless defined $offset;
 337     }
 338     else {
 339         $category = (caller(1))[0] ;
 340         $offset = $Offsets{$category};
 341         croak("package '$category' not registered for warnings")
 342             unless defined $offset ;
 343     }
 344
 345     my $this_pkg = (caller(1))[0] ;
 346     my $i = 2 ;
 347     my $pkg ;
 348
 349     if ($isobj) {
 350         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 351             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 352         }
 353         $i -= 2 ;
 354     }
 355     else {
 356         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 357             last if $pkg ne $this_pkg ;
 358         }
 359         $i = 2
 360             if !$pkg || $pkg eq $this_pkg ;
 361     }
 362
 363     my $callers_bitmask = (caller($i))[9] ;
 364     return ($callers_bitmask, $offset, $i) ;
 365 }
 366
 367 sub enabled
 368 {
 369     croak("Usage: warnings::enabled([category])")
 370         unless @_ == 1 || @_ == 0 ;
 371
 372     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 373
 374     return 0 unless defined $callers_bitmask ;
 375     return vec($callers_bitmask, $offset, 1) ||
 376            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 377 }
 378
 379
 380 sub warn
 381 {
 382     croak("Usage: warnings::warn([category,] 'message')")
 383         unless @_ == 2 || @_ == 1 ;
 384
 385     my $message = pop ;
 386     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 387     local $Carp::CarpLevel = $i ;
 388     croak($message)
 389         if vec($callers_bitmask, $offset+1, 1) ||
 390            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 391     carp($message) ;
 392 }
 393
 394 sub warnif
 395 {
 396     croak("Usage: warnings::warnif([category,] 'message')")
 397         unless @_ == 2 || @_ == 1 ;
 398
 399     my $message = pop ;
 400     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 401     local $Carp::CarpLevel = $i ;
 402
 403     return
 404         unless defined $callers_bitmask &&
 405                 (vec($callers_bitmask, $offset, 1) ||
 406                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 407
 408     croak($message)
 409         if vec($callers_bitmask, $offset+1, 1) ||
 410            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 411
 412     carp($message) ;
 413 }
 414 1;