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