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     if (warnings::enabled("void") {
  21         warnings::warn("void", "some warning");
  22     }
  23
  24 =head1 DESCRIPTION
  25
  26 If no import list is supplied, all possible warnings are either enabled
  27 or disabled.
  28
  29 Two functions are provided to assist module authors.
  30
  31 =over 4
  32
  33 =item warnings::enabled($category)
  34
  35 Returns TRUE if the warnings category in C<$category> is enabled in the
  36 calling module. Otherwise returns FALSE.
  37
  38
  39 =item warnings::warn($category, $message)
  40
  41 If the calling module has I<not> set C<$category> to "FATAL", print
  42 C<$message> to STDERR.
  43 If the calling module has set C<$category> to "FATAL", print C<$message>
  44 STDERR then die.
  45
  46 =back
  47
  48 See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
  49
  50 =cut
  51
  52 use Carp ;
  53
  54 %Bits = (
  55     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
  56     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
  57     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
  58     'chmod'             => "\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0]
  59     'closed'            => "\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
  60     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
  61     'debugging'         => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
  62     'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
  63     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
  64     'exec'              => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
  65     'exiting'           => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
  66     'glob'              => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
  67     'inplace'           => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
  68     'internal'          => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
  69     'io'                => "\x00\x55\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
  70     'malloc'            => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
  71     'misc'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
  72     'newline'           => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
  73     'numeric'           => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
  74     'once'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
  75     'overflow'          => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
  76     'pack'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
  77     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
  78     'pipe'              => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
  79     'portable'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
  80     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
  81     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
  82     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
  83     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
  84     'recursion'         => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
  85     'redefine'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
  86     'regexp'            => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
  87     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
  88     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
  89     'severe'            => "\x00\x00\x00\x00\x40\x55\x00\x00\x00\x00\x00\x00", # [19..23]
  90     'signal'            => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
  91     'substr'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
  92     'syntax'            => "\x00\x00\x00\x00\x00\x00\x50\x55\x55\x05\x00\x00", # [26..37]
  93     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
  94     'umask'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
  95     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
  96     'unopened'          => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
  97     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
  98     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
  99     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 100     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 101     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 102   );
 103
 104 %DeadBits = (
 105     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
 106     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
 107     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
 108     'chmod'             => "\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0]
 109     'closed'            => "\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
 110     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 111     'debugging'         => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
 112     'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
 113     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
 114     'exec'              => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 115     'exiting'           => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 116     'glob'              => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 117     'inplace'           => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
 118     'internal'          => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
 119     'io'                => "\x00\xaa\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
 120     'malloc'            => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
 121     'misc'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 122     'newline'           => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 123     'numeric'           => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 124     'once'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 125     'overflow'          => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 126     'pack'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 127     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
 128     'pipe'              => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 129     'portable'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 130     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
 131     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
 132     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
 133     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
 134     'recursion'         => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
 135     'redefine'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
 136     'regexp'            => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
 137     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
 138     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
 139     'severe'            => "\x00\x00\x00\x00\x80\xaa\x00\x00\x00\x00\x00\x00", # [19..23]
 140     'signal'            => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
 141     'substr'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
 142     'syntax'            => "\x00\x00\x00\x00\x00\x00\xa0\xaa\xaa\x0a\x00\x00", # [26..37]
 143     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
 144     'umask'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
 145     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
 146     'unopened'          => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 147     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
 148     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
 149     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
 150     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
 151     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
 152   );
 153
 154 $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
 155
 156 sub bits {
 157     my $mask ;
 158     my $catmask ;
 159     my $fatal = 0 ;
 160     foreach my $word (@_) {
 161         if  ($word eq 'FATAL') {
 162             $fatal = 1;
 163         }
 164         else {
 165             if ($catmask = $Bits{$word}) {
 166                 $mask |= $catmask ;
 167                 $mask |= $DeadBits{$word} if $fatal ;
 168             }
 169         }
 170     }
 171
 172     return $mask ;
 173 }
 174
 175 sub import {
 176     shift;
 177     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
 178 }
 179
 180 sub unimport {
 181     shift;
 182     ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
 183 }
 184
 185 sub enabled
 186 {
 187     # If no parameters, check for any lexical warnings enabled
 188     # in the users scope.
 189     my $callers_bitmask = (caller(1))[9] ;
 190     return ($callers_bitmask ne $NONE) if @_ == 0 ;
 191
 192     # otherwise check for the category supplied.
 193     my $category = shift ;
 194     return 0
 195         unless $Bits{$category} ;
 196     return 0 unless defined $callers_bitmask ;
 197     return 1
 198         if ($callers_bitmask & $Bits{$category}) ne $NONE ;
 199
 200     return 0 ;
 201 }
 202
 203 sub warn
 204 {
 205     croak "Usage: warnings::warn('category', 'message')"
 206         unless @_ == 2 ;
 207     my $category = shift ;
 208     my $message = shift ;
 209     local $Carp::CarpLevel = 1 ;
 210     my $callers_bitmask = (caller(1))[9] ;
 211     croak($message)
 212         if defined $callers_bitmask &&
 213            ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
 214     carp($message) ;
 215 }
 216
 217 1;