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