lib/warning.pm

   1
   2 # This file was created by warning.pl
   3 # Any changes made here will be lost.
   4 #
   5
   6 package warning;
   7
   8 =head1 NAME
   9
  10 warning - Perl pragma to control
  11
  12 =head1 SYNOPSIS
  13
  14     use warning;
  15
  16     use warning "all";
  17     use warning "deprecated";
  18
  19     use warning;
  20     no warning "unsafe";
  21
  22 =head1 DESCRIPTION
  23
  24 If no import list is supplied, all possible restrictions are assumed.
  25 (This is the safest mode to operate in, but is sometimes too strict for
  26 casual programming.)  Currently, there are three possible things to be
  27 strict about:
  28
  29 =over 6
  30
  31 =item C<warning deprecated>
  32
  33 This generates a runtime error if you use deprecated
  34
  35     use warning 'deprecated';
  36
  37 =back
  38
  39 See L<perlmod/Pragmatic Modules>.
  40
  41
  42 =cut
  43
  44 use Carp ;
  45
  46 %Bits = (
  47     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55", # [0..31]
  48     'ambiguous'         => "\x00\x00\x00\x04\x00\x00\x00\x00", # [13]
  49     'closed'            => "\x10\x00\x00\x00\x00\x00\x00\x00", # [2]
  50     'closure'           => "\x00\x00\x00\x00\x00\x40\x00\x00", # [23]
  51     'default'           => "\x01\x00\x00\x00\x00\x00\x00\x00", # [0]
  52     'deprecated'        => "\x00\x00\x00\x10\x00\x00\x00\x00", # [14]
  53     'exec'              => "\x40\x00\x00\x00\x00\x00\x00\x00", # [3]
  54     'io'                => "\x54\x15\x00\x00\x00\x00\x00\x00", # [1..6]
  55     'misc'              => "\x00\x40\x00\x00\x00\x00\x00\x00", # [7]
  56     'newline'           => "\x00\x01\x00\x00\x00\x00\x00\x00", # [4]
  57     'numeric'           => "\x00\x00\x01\x00\x00\x00\x00\x00", # [8]
  58     'octal'             => "\x00\x00\x00\x40\x00\x00\x00\x00", # [15]
  59     'once'              => "\x00\x00\x04\x00\x00\x00\x00\x00", # [9]
  60     'parenthesis'       => "\x00\x00\x00\x00\x01\x00\x00\x00", # [16]
  61     'pipe'              => "\x00\x04\x00\x00\x00\x00\x00\x00", # [5]
  62     'precedence'        => "\x00\x00\x00\x00\x04\x00\x00\x00", # [17]
  63     'printf'            => "\x00\x00\x00\x00\x10\x00\x00\x00", # [18]
  64     'recursion'         => "\x00\x00\x10\x00\x00\x00\x00\x00", # [10]
  65     'redefine'          => "\x00\x00\x40\x00\x00\x00\x00\x00", # [11]
  66     'reserved'          => "\x00\x00\x00\x00\x40\x00\x00\x00", # [19]
  67     'semicolon'         => "\x00\x00\x00\x00\x00\x01\x00\x00", # [20]
  68     'signal'            => "\x00\x00\x00\x00\x00\x00\x01\x00", # [24]
  69     'substr'            => "\x00\x00\x00\x00\x00\x00\x04\x00", # [25]
  70     'syntax'            => "\x00\x00\x00\x55\x55\x01\x00\x00", # [12..20]
  71     'taint'             => "\x00\x00\x00\x00\x00\x00\x10\x00", # [26]
  72     'uninitialized'     => "\x00\x00\x00\x00\x00\x04\x00\x00", # [21]
  73     'unopened'          => "\x00\x10\x00\x00\x00\x00\x00\x00", # [6]
  74     'unsafe'            => "\x00\x00\x00\x00\x00\x50\x55\x01", # [22..28]
  75     'untie'             => "\x00\x00\x00\x00\x00\x00\x40\x00", # [27]
  76     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x01", # [28]
  77     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x04", # [29]
  78   );
  79
  80 %DeadBits = (
  81     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..31]
  82     'ambiguous'         => "\x00\x00\x00\x08\x00\x00\x00\x00", # [13]
  83     'closed'            => "\x20\x00\x00\x00\x00\x00\x00\x00", # [2]
  84     'closure'           => "\x00\x00\x00\x00\x00\x80\x00\x00", # [23]
  85     'default'           => "\x02\x00\x00\x00\x00\x00\x00\x00", # [0]
  86     'deprecated'        => "\x00\x00\x00\x20\x00\x00\x00\x00", # [14]
  87     'exec'              => "\x80\x00\x00\x00\x00\x00\x00\x00", # [3]
  88     'io'                => "\xa8\x2a\x00\x00\x00\x00\x00\x00", # [1..6]
  89     'misc'              => "\x00\x80\x00\x00\x00\x00\x00\x00", # [7]
  90     'newline'           => "\x00\x02\x00\x00\x00\x00\x00\x00", # [4]
  91     'numeric'           => "\x00\x00\x02\x00\x00\x00\x00\x00", # [8]
  92     'octal'             => "\x00\x00\x00\x80\x00\x00\x00\x00", # [15]
  93     'once'              => "\x00\x00\x08\x00\x00\x00\x00\x00", # [9]
  94     'parenthesis'       => "\x00\x00\x00\x00\x02\x00\x00\x00", # [16]
  95     'pipe'              => "\x00\x08\x00\x00\x00\x00\x00\x00", # [5]
  96     'precedence'        => "\x00\x00\x00\x00\x08\x00\x00\x00", # [17]
  97     'printf'            => "\x00\x00\x00\x00\x20\x00\x00\x00", # [18]
  98     'recursion'         => "\x00\x00\x20\x00\x00\x00\x00\x00", # [10]
  99     'redefine'          => "\x00\x00\x80\x00\x00\x00\x00\x00", # [11]
 100     'reserved'          => "\x00\x00\x00\x00\x80\x00\x00\x00", # [19]
 101     'semicolon'         => "\x00\x00\x00\x00\x00\x02\x00\x00", # [20]
 102     'signal'            => "\x00\x00\x00\x00\x00\x00\x02\x00", # [24]
 103     'substr'            => "\x00\x00\x00\x00\x00\x00\x08\x00", # [25]
 104     'syntax'            => "\x00\x00\x00\xaa\xaa\x02\x00\x00", # [12..20]
 105     'taint'             => "\x00\x00\x00\x00\x00\x00\x20\x00", # [26]
 106     'uninitialized'     => "\x00\x00\x00\x00\x00\x08\x00\x00", # [21]
 107     'unopened'          => "\x00\x20\x00\x00\x00\x00\x00\x00", # [6]
 108     'unsafe'            => "\x00\x00\x00\x00\x00\xa0\xaa\x02", # [22..28]
 109     'untie'             => "\x00\x00\x00\x00\x00\x00\x80\x00", # [27]
 110     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x02", # [28]
 111     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x08", # [29]
 112   );
 113
 114
 115 sub bits {
 116     my $mask ;
 117     my $catmask ;
 118     my $fatal = 0 ;
 119     foreach my $word (@_) {
 120         if  ($word eq 'FATAL')
 121           { $fatal = 1 }
 122         elsif ($catmask = $Bits{$word}) {
 123           $mask |= $catmask ;
 124           $mask |= $DeadBits{$word} if $fatal ;
 125         }
 126         else
 127           { croak "unknown warning category '$word'" }
 128     }
 129
 130     return $mask ;
 131 }
 132
 133 sub import {
 134     shift;
 135     $^B |= bits(@_ ? @_ : 'all') ;
 136 }
 137
 138 sub unimport {
 139     shift;
 140     $^B &= ~ bits(@_ ? @_ : 'all') ;
 141 }
 142
 143
 144 sub make_fatal
 145 {
 146     my $self = shift ;
 147     my $bitmask = $self->bits(@_) ;
 148     $SIG{__WARN__} =
 149         sub
 150         {
 151             die @_ if $^B & $bitmask ;
 152             warn @_
 153         } ;
 154 }
 155
 156 sub bitmask
 157 {
 158     return $^B ;
 159 }
 160
 161 sub enabled
 162 {
 163     my $string = shift ;
 164
 165     return 1
 166         if $bits{$string} && $^B & $bits{$string} ;
 167
 168     return 0 ;
 169 }
 170
 171 1;