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