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     warnif("some warning");
  36     warnif("void", "some warning");
  37     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     'exiting'           => 4,
 135     'glob'              => 6,
 136     'io'                => 8,
 137     'closed'            => 10,
 138     'exec'              => 12,
 139     'newline'           => 14,
 140     'pipe'              => 16,
 141     'unopened'          => 18,
 142     'misc'              => 20,
 143     'numeric'           => 22,
 144     'octmode'           => 24,
 145     'chmod'             => 26,
 146     'mkdir'             => 28,
 147     'umask'             => 30,
 148     'once'              => 32,
 149     'overflow'          => 34,
 150     'pack'              => 36,
 151     'portable'          => 38,
 152     'recursion'         => 40,
 153     'redefine'          => 42,
 154     'regexp'            => 44,
 155     'severe'            => 46,
 156     'debugging'         => 48,
 157     'inplace'           => 50,
 158     'internal'          => 52,
 159     'malloc'            => 54,
 160     'signal'            => 56,
 161     'substr'            => 58,
 162     'syntax'            => 60,
 163     'ambiguous'         => 62,
 164     'bareword'          => 64,
 165     'deprecated'        => 66,
 166     'digit'             => 68,
 167     'parenthesis'       => 70,
 168     'precedence'        => 72,
 169     'printf'            => 74,
 170     'prototype'         => 76,
 171     'qw'                => 78,
 172     'reserved'          => 80,
 173     'semicolon'         => 82,
 174     'taint'             => 84,
 175     'uninitialized'     => 86,
 176     'unpack'            => 88,
 177     'untie'             => 90,
 178     'utf8'              => 92,
 179     'void'              => 94,
 180     'y2k'               => 96,
 181   );
 182
 183 %Bits = (
 184     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..48]
 185     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [31]
 186     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [32]
 187     'chmod'             => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 188     'closed'            => "\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
 189     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 190     'debugging'         => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [24]
 191     'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [33]
 192     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [34]
 193     'exec'              => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 194     'exiting'           => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 195     'glob'              => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 196     'inplace'           => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [25]
 197     'internal'          => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [26]
 198     'io'                => "\x00\x55\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
 199     'malloc'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [27]
 200     'misc'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 201     'mkdir'             => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 202     'newline'           => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 203     'numeric'           => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 204     'octmode'           => "\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12..15]
 205     'once'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
 206     'overflow'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
 207     'pack'              => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
 208     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [35]
 209     'pipe'              => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 210     'portable'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
 211     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [36]
 212     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [37]
 213     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [38]
 214     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [39]
 215     'recursion'         => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [20]
 216     'redefine'          => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [21]
 217     'regexp'            => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [22]
 218     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [40]
 219     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [41]
 220     'severe'            => "\x00\x00\x00\x00\x00\x40\x55\x00\x00\x00\x00\x00\x00", # [23..27]
 221     'signal'            => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [28]
 222     'substr'            => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [29]
 223     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x50\x55\x55\x05\x00\x00", # [30..41]
 224     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [42]
 225     'umask'             => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 226     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [43]
 227     'unopened'          => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 228     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [44]
 229     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [45]
 230     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [46]
 231     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [47]
 232     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [48]
 233   );
 234
 235 %DeadBits = (
 236     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..48]
 237     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [31]
 238     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [32]
 239     'chmod'             => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 240     'closed'            => "\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
 241     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 242     'debugging'         => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [24]
 243     'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [33]
 244     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [34]
 245     'exec'              => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 246     'exiting'           => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 247     'glob'              => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 248     'inplace'           => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [25]
 249     'internal'          => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [26]
 250     'io'                => "\x00\xaa\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
 251     'malloc'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [27]
 252     'misc'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 253     'mkdir'             => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 254     'newline'           => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 255     'numeric'           => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 256     'octmode'           => "\x00\x00\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12..15]
 257     'once'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
 258     'overflow'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
 259     'pack'              => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
 260     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [35]
 261     'pipe'              => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 262     'portable'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
 263     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [36]
 264     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [37]
 265     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [38]
 266     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [39]
 267     'recursion'         => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [20]
 268     'redefine'          => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [21]
 269     'regexp'            => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [22]
 270     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [40]
 271     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [41]
 272     'severe'            => "\x00\x00\x00\x00\x00\x80\xaa\x00\x00\x00\x00\x00\x00", # [23..27]
 273     'signal'            => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [28]
 274     'substr'            => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [29]
 275     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xa0\xaa\xaa\x0a\x00\x00", # [30..41]
 276     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [42]
 277     'umask'             => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 278     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [43]
 279     'unopened'          => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 280     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [44]
 281     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [45]
 282     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [46]
 283     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [47]
 284     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [48]
 285   );
 286
 287 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0\0";
 288 $LAST_BIT = 98 ;
 289 $BYTES    = 13 ;
 290
 291 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 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           { croak("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(@_ ? @_ : '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             croak ("not an object")
 343                 if $category !~ /^([^=]+)=/ ;+
 344             $category = $1 ;
 345             $isobj = 1 ;
 346         }
 347         $offset = $Offsets{$category};
 348         croak("unknown warnings category '$category'")
 349             unless defined $offset;
 350     }
 351     else {
 352         $category = (caller(1))[0] ;
 353         $offset = $Offsets{$category};
 354         croak("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     croak("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     croak("Usage: warnings::warn([category,] 'message')")
 396         unless @_ == 2 || @_ == 1 ;
 397
 398     my $message = pop ;
 399     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 400     local $Carp::CarpLevel = $i ;
 401     croak($message)
 402         if vec($callers_bitmask, $offset+1, 1) ||
 403            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 404     carp($message) ;
 405 }
 406
 407 sub warnif
 408 {
 409     croak("Usage: warnings::warnif([category,] 'message')")
 410         unless @_ == 2 || @_ == 1 ;
 411
 412     my $message = pop ;
 413     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 414     local $Carp::CarpLevel = $i ;
 415
 416     return
 417         unless defined $callers_bitmask &&
 418                 (vec($callers_bitmask, $offset, 1) ||
 419                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 420
 421     croak($message)
 422         if vec($callers_bitmask, $offset+1, 1) ||
 423            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 424
 425     carp($message) ;
 426 }
 427 1;