warning.pl

   1 #!/usr/bin/perl
   2
   3 BEGIN {
   4   push @INC, './lib';
   5 }
   6 use strict ;
   7
   8 sub DEFAULT_ON  () { 1 }
   9 sub DEFAULT_OFF () { 2 }
  10
  11 my $tree = {
  12          'unsafe'       => {    'untie'         => DEFAULT_OFF,
  13                                 'substr'        => DEFAULT_OFF,
  14                                 'taint'         => DEFAULT_OFF,
  15                                 'signal'        => DEFAULT_OFF,
  16                                 'closure'       => DEFAULT_OFF,
  17                                 'utf8'          => DEFAULT_OFF,
  18                            } ,
  19          'io'           => {    'pipe'          => DEFAULT_OFF,
  20                                 'unopened'      => DEFAULT_OFF,
  21                                 'closed'        => DEFAULT_OFF,
  22                                 'newline'       => DEFAULT_OFF,
  23                                 'exec'          => DEFAULT_OFF,
  24                                 #'wr in in file'=> DEFAULT_OFF,
  25                            },
  26          'syntax'       => {    'ambiguous'     => DEFAULT_OFF,
  27                                 'semicolon'     => DEFAULT_OFF,
  28                                 'precedence'    => DEFAULT_OFF,
  29                                 'reserved'      => DEFAULT_OFF,
  30                                 'octal'         => DEFAULT_OFF,
  31                                 'parenthesis'   => DEFAULT_OFF,
  32                                 'deprecated'    => DEFAULT_OFF,
  33                                 'printf'        => DEFAULT_OFF,
  34                            },
  35          'severe'       => {    'inplace'       => DEFAULT_ON,
  36                                 'internal'      => DEFAULT_ON,
  37                                 'debugging'     => DEFAULT_ON,
  38                            },
  39          'void'         => DEFAULT_OFF,
  40          'recursion'    => DEFAULT_OFF,
  41          'redefine'     => DEFAULT_OFF,
  42          'numeric'      => DEFAULT_OFF,
  43          'uninitialized'=> DEFAULT_OFF,
  44          'once'         => DEFAULT_OFF,
  45          'misc'         => DEFAULT_OFF,
  46          #'default'     => DEFAULT_ON,
  47         } ;
  48
  49
  50 ###########################################################################
  51 sub tab {
  52     my($l, $t) = @_;
  53     $t .= "\t" x ($l - (length($t) + 1) / 8);
  54     $t;
  55 }
  56
  57 ###########################################################################
  58
  59 my %list ;
  60 my %Value ;
  61 my $index = 0 ;
  62
  63 sub walk
  64 {
  65     my $tre = shift ;
  66     my @list = () ;
  67     my ($k, $v) ;
  68
  69     foreach $k (sort keys %$tre) {
  70         $v = $tre->{$k};
  71         die "duplicate key $k\n" if defined $list{$k} ;
  72         $Value{$index} = uc $k ;
  73         push @{ $list{$k} }, $index ++ ;
  74         if (ref $v)
  75           { push (@{ $list{$k} }, walk ($v)) }
  76         push @list, @{ $list{$k} } ;
  77     }
  78
  79    return @list ;
  80 }
  81
  82 ###########################################################################
  83
  84 sub mkRange
  85 {
  86     my @a = @_ ;
  87     my @out = @a ;
  88     my $i ;
  89
  90
  91     for ($i = 1 ; $i < @a; ++ $i) {
  92         $out[$i] = ".."
  93           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
  94     }
  95
  96     my $out = join(",",@out);
  97
  98     $out =~ s/,(\.\.,)+/../g ;
  99     return $out;
 100 }
 101
 102 ###########################################################################
 103
 104 sub mkHex
 105 {
 106     my ($max, @a) = @_ ;
 107     my $mask = "\x00" x $max ;
 108     my $string = "" ;
 109
 110     foreach (@a) {
 111         vec($mask, $_, 1) = 1 ;
 112     }
 113
 114     #$string = unpack("H$max", $mask) ;
 115     #$string =~ s/(..)/\x$1/g;
 116     foreach (unpack("C*", $mask)) {
 117         $string .= '\x' . sprintf("%2.2x", $_) ;
 118     }
 119     return $string ;
 120 }
 121
 122 ###########################################################################
 123
 124
 125 #unlink "warning.h";
 126 #unlink "lib/warning.pm";
 127 open(WARN, ">warning.h") || die "Can't create warning.h: $!\n";
 128 open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n";
 129
 130 print WARN <<'EOM' ;
 131 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 132    This file is built by warning.pl
 133    Any changes made here will be lost!
 134 */
 135
 136
 137 #define Off(x)                  ((x) / 8)
 138 #define Bit(x)                  (1 << ((x) % 8))
 139 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
 140
 141
 142 #define G_WARN_OFF              0       /* $^W == 0 */
 143 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
 144 #define G_WARN_ALL_ON           2       /* -W flag */
 145 #define G_WARN_ALL_OFF          4       /* -X flag */
 146 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
 147 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 148
 149 #define WARN_STD                Nullsv
 150 #define WARN_ALL                (&PL_sv_yes)    /* use warning 'all' */
 151 #define WARN_NONE               (&PL_sv_no)     /* no  warning 'all' */
 152
 153 #define specialWARN(x)          ((x) == WARN_STD || (x) == WARN_ALL ||  \
 154                                  (x) == WARN_NONE)
 155
 156 #define ckDEAD(x)                                                       \
 157            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 158             IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
 159
 160 #define ckWARN(x)                                                       \
 161         ( (PL_curcop->cop_warnings != WARN_STD &&                       \
 162            PL_curcop->cop_warnings != WARN_NONE &&                      \
 163               (PL_curcop->cop_warnings == WARN_ALL ||                   \
 164                IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )           \
 165           || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
 166
 167 #define ckWARN2(x,y)                                                    \
 168           ( (PL_curcop->cop_warnings != WARN_STD  &&                    \
 169              PL_curcop->cop_warnings != WARN_NONE &&                    \
 170               (PL_curcop->cop_warnings == WARN_ALL ||                   \
 171                 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||          \
 172                 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) )          \
 173             ||  (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
 174
 175 #define ckWARN_d(x)                                                     \
 176           (PL_curcop->cop_warnings == WARN_STD ||                       \
 177            PL_curcop->cop_warnings == WARN_ALL ||                       \
 178              (PL_curcop->cop_warnings != WARN_NONE &&                   \
 179               IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
 180
 181 #define ckWARN2_d(x,y)                                                  \
 182           (PL_curcop->cop_warnings == WARN_STD ||                       \
 183            PL_curcop->cop_warnings == WARN_ALL ||                       \
 184              (PL_curcop->cop_warnings != WARN_NONE &&                   \
 185                 (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||         \
 186                  IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
 187
 188
 189 #define isLEXWARN_on    (PL_curcop->cop_warnings != WARN_STD)
 190 #define isLEXWARN_off   (PL_curcop->cop_warnings == WARN_STD)
 191 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 192 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
 193
 194 EOM
 195
 196
 197 $index = 0 ;
 198 @{ $list{"all"} } = walk ($tree) ;
 199
 200 $index *= 2 ;
 201 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 202
 203 my $k ;
 204 foreach $k (sort { $a <=> $b } keys %Value) {
 205     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
 206 }
 207 print WARN "\n" ;
 208
 209 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
 210 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 211 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 212 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
 213
 214 print WARN <<'EOM';
 215
 216 /* end of file warning.h */
 217
 218 EOM
 219
 220 close WARN ;
 221
 222 while (<DATA>) {
 223     last if /^KEYWORDS$/ ;
 224     print PM $_ ;
 225 }
 226
 227 $list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
 228 print PM "%Bits = (\n" ;
 229 foreach $k (sort keys  %list) {
 230
 231     my $v = $list{$k} ;
 232     my @list = sort { $a <=> $b } @$v ;
 233
 234     print PM tab(4, "    '$k'"), '=> "',
 235                 # mkHex($warn_size, @list),
 236                 mkHex($warn_size, map $_ * 2 , @list),
 237                 '", # [', mkRange(@list), "]\n" ;
 238 }
 239
 240 print PM "  );\n\n" ;
 241
 242 print PM "%DeadBits = (\n" ;
 243 foreach $k (sort keys  %list) {
 244
 245     my $v = $list{$k} ;
 246     my @list = sort { $a <=> $b } @$v ;
 247
 248     print PM tab(4, "    '$k'"), '=> "',
 249                 # mkHex($warn_size, @list),
 250                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 251                 '", # [', mkRange(@list), "]\n" ;
 252 }
 253
 254 print PM "  );\n\n" ;
 255 while (<DATA>) {
 256     print PM $_ ;
 257 }
 258
 259 close PM ;
 260
 261 __END__
 262
 263 # This file was created by warning.pl
 264 # Any changes made here will be lost.
 265 #
 266
 267 package warning;
 268
 269 =head1 NAME
 270
 271 warning - Perl pragma to control optional warnings
 272
 273 =head1 SYNOPSIS
 274
 275     use warning;
 276     no warning;
 277
 278     use warning "all";
 279     no warning "all";
 280
 281 =head1 DESCRIPTION
 282
 283 If no import list is supplied, all possible warnings are either enabled
 284 or disabled.
 285
 286 See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
 287
 288
 289 =cut
 290
 291 use Carp ;
 292
 293 KEYWORDS
 294
 295 sub bits {
 296     my $mask ;
 297     my $catmask ;
 298     my $fatal = 0 ;
 299     foreach my $word (@_) {
 300         if  ($word eq 'FATAL')
 301           { $fatal = 1 }
 302         elsif ($catmask = $Bits{$word}) {
 303           $mask |= $catmask ;
 304           $mask |= $DeadBits{$word} if $fatal ;
 305         }
 306         else
 307           { croak "unknown warning category '$word'" }
 308     }
 309
 310     return $mask ;
 311 }
 312
 313 sub import {
 314     shift;
 315     $^B |= bits(@_ ? @_ : 'all') ;
 316 }
 317
 318 sub unimport {
 319     shift;
 320     $^B &= ~ bits(@_ ? @_ : 'all') ;
 321 }
 322
 323
 324 sub make_fatal
 325 {
 326     my $self = shift ;
 327     my $bitmask = $self->bits(@_) ;
 328     $SIG{__WARN__} =
 329         sub
 330         {
 331             die @_ if $^B & $bitmask ;
 332             warn @_
 333         } ;
 334 }
 335
 336 sub bitmask
 337 {
 338     return $^B ;
 339 }
 340
 341 sub enabled
 342 {
 343     my $string = shift ;
 344
 345     return 1
 346         if $bits{$string} && $^B & $bits{$string} ;
 347
 348     return 0 ;
 349 }
 350
 351 1;