warning.pl

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