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