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 =head1 DESCRIPTION
  30
  31 If no import list is supplied, all possible warnings are either enabled
  32 or disabled.
  33
  34 A number of functions are provided to assist module authors.
  35
  36 =over 4
  37
  38 =item use warnings::register
  39
  40 Creates a new warnings category which has the same name as the module
  41 where the call to the pragma is used.
  42
  43 =item warnings::enabled([$category])
  44
  45 Returns TRUE if the warnings category C<$category> is enabled in the
  46 calling module.  Otherwise returns FALSE.
  47
  48 If the parameter, C<$category>, isn't supplied, the current package name
  49 will be used.
  50
  51 =item warnings::warn([$category,] $message)
  52
  53 If the calling module has I<not> set C<$category> to "FATAL", print
  54 C<$message> to STDERR.
  55 If the calling module has set C<$category> to "FATAL", print C<$message>
  56 STDERR then die.
  57
  58 If the parameter, C<$category>, isn't supplied, the current package name
  59 will be used.
  60
  61 =back
  62
  63 See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
  64
  65 =cut
  66
  67 use Carp ;
  68
  69 %Offsets = (
  70     'all'               => 0,
  71     'chmod'             => 2,
  72     'closure'           => 4,
  73     'exiting'           => 6,
  74     'glob'              => 8,
  75     'io'                => 10,
  76     'closed'            => 12,
  77     'exec'              => 14,
  78     'newline'           => 16,
  79     'pipe'              => 18,
  80     'unopened'          => 20,
  81     'misc'              => 22,
  82     'numeric'           => 24,
  83     'once'              => 26,
  84     'overflow'          => 28,
  85     'pack'              => 30,
  86     'portable'          => 32,
  87     'recursion'         => 34,
  88     'redefine'          => 36,
  89     'regexp'            => 38,
  90     'severe'            => 40,
  91     'debugging'         => 42,
  92     'inplace'           => 44,
  93     'internal'          => 46,
  94     'malloc'            => 48,
  95     'signal'            => 50,
  96     'substr'            => 52,
  97     'syntax'            => 54,
  98     'ambiguous'         => 56,
  99     'bareword'          => 58,
 100     'deprecated'        => 60,
 101     'digit'             => 62,
 102     'parenthesis'       => 64,
 103     'precedence'        => 66,
 104     'printf'            => 68,
 105     'prototype'         => 70,
 106     'qw'                => 72,
 107     'reserved'          => 74,
 108     'semicolon'         => 76,
 109     'taint'             => 78,
 110     'umask'             => 80,
 111     'uninitialized'     => 82,
 112     'unpack'            => 84,
 113     'untie'             => 86,
 114     'utf8'              => 88,
 115     'void'              => 90,
 116     'y2k'               => 92,
 117   );
 118
 119 %Bits = (
 120     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
 121     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
 122     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
 123     'chmod'             => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 124     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 125     'closure'           => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 126     'debugging'         => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
 127     'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
 128     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
 129     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 130     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 131     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 132     'inplace'           => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
 133     'internal'          => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
 134     'io'                => "\x00\x54\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
 135     'malloc'            => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
 136     'misc'              => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 137     'newline'           => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 138     'numeric'           => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 139     'once'              => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 140     'overflow'          => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 141     'pack'              => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 142     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
 143     'pipe'              => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 144     'portable'          => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
 145     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
 146     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
 147     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
 148     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
 149     'recursion'         => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
 150     'redefine'          => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
 151     'regexp'            => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
 152     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
 153     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
 154     'severe'            => "\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00", # [20..24]
 155     'signal'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
 156     'substr'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
 157     'syntax'            => "\x00\x00\x00\x00\x00\x00\x40\x55\x55\x15\x00\x00", # [27..38]
 158     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
 159     'umask'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
 160     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
 161     'unopened'          => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 162     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
 163     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
 164     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
 165     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
 166     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
 167   );
 168
 169 %DeadBits = (
 170     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
 171     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
 172     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
 173     'chmod'             => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
 174     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
 175     'closure'           => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
 176     'debugging'         => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
 177     'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
 178     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
 179     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
 180     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
 181     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
 182     'inplace'           => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
 183     'internal'          => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
 184     'io'                => "\x00\xa8\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
 185     'malloc'            => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
 186     'misc'              => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
 187     'newline'           => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
 188     'numeric'           => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
 189     'once'              => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
 190     'overflow'          => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
 191     'pack'              => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
 192     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
 193     'pipe'              => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
 194     'portable'          => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
 195     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
 196     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
 197     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
 198     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
 199     'recursion'         => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
 200     'redefine'          => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
 201     'regexp'            => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
 202     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
 203     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
 204     'severe'            => "\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x00", # [20..24]
 205     'signal'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
 206     'substr'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
 207     'syntax'            => "\x00\x00\x00\x00\x00\x00\x80\xaa\xaa\x2a\x00\x00", # [27..38]
 208     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
 209     'umask'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
 210     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
 211     'unopened'          => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
 212     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
 213     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
 214     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
 215     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
 216     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
 217   );
 218
 219 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
 220 $LAST_BIT = 94 ;
 221 $BYTES    = 12 ;
 222
 223 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 224
 225 sub bits {
 226     my $mask ;
 227     my $catmask ;
 228     my $fatal = 0 ;
 229     foreach my $word (@_) {
 230         if  ($word eq 'FATAL') {
 231             $fatal = 1;
 232         }
 233         elsif ($catmask = $Bits{$word}) {
 234             $mask |= $catmask ;
 235             $mask |= $DeadBits{$word} if $fatal ;
 236         }
 237         else
 238           { croak("unknown warnings category '$word'")}
 239     }
 240
 241     return $mask ;
 242 }
 243
 244 sub import {
 245     shift;
 246     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
 247 }
 248
 249 sub unimport {
 250     shift;
 251     my $mask = ${^WARNING_BITS} ;
 252     if (vec($mask, $Offsets{'all'}, 1)) {
 253         $mask = $Bits{'all'} ;
 254         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 255     }
 256     ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
 257 }
 258
 259 sub enabled
 260 {
 261     croak("Usage: warnings::enabled([category])")
 262         unless @_ == 1 || @_ == 0 ;
 263     local $Carp::CarpLevel = 1 ;
 264     my $category ;
 265     my $offset ;
 266     my $callers_bitmask = (caller(1))[9] ;
 267     return 0 unless defined $callers_bitmask ;
 268
 269
 270     if (@_) {
 271         # check the category supplied.
 272         $category = shift ;
 273         $offset = $Offsets{$category};
 274         croak("unknown warnings category '$category'")
 275             unless defined $offset;
 276     }
 277     else {
 278         $category = (caller(0))[0] ;
 279         $offset = $Offsets{$category};
 280         croak("package '$category' not registered for warnings")
 281             unless defined $offset ;
 282     }
 283
 284     return vec($callers_bitmask, $offset, 1) ||
 285            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 286 }
 287
 288
 289 sub warn
 290 {
 291     croak("Usage: warnings::warn([category,] 'message')")
 292         unless @_ == 2 || @_ == 1 ;
 293     local $Carp::CarpLevel = 1 ;
 294     my $category ;
 295     my $offset ;
 296     my $callers_bitmask = (caller(1))[9] ;
 297
 298     if (@_ == 2) {
 299         $category = shift ;
 300         $offset = $Offsets{$category};
 301         croak("unknown warnings category '$category'")
 302             unless defined $offset ;
 303     }
 304     else {
 305         $category = (caller(0))[0] ;
 306         $offset = $Offsets{$category};
 307         croak("package '$category' not registered for warnings")
 308             unless defined $offset ;
 309     }
 310
 311     my $message = shift ;
 312     croak($message)
 313         if vec($callers_bitmask, $offset+1, 1) ||
 314            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 315     carp($message) ;
 316 }
 317
 318 1;