warnings.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         'io'            => {    'pipe'          => DEFAULT_OFF,
  13                                 'unopened'      => DEFAULT_OFF,
  14                                 'closed'        => DEFAULT_OFF,
  15                                 'newline'       => DEFAULT_OFF,
  16                                 'exec'          => DEFAULT_OFF,
  17                            },
  18         'syntax'        => {    'ambiguous'     => DEFAULT_OFF,
  19                                 'semicolon'     => DEFAULT_OFF,
  20                                 'precedence'    => DEFAULT_OFF,
  21                                 'bareword'      => DEFAULT_OFF,
  22                                 'reserved'      => DEFAULT_OFF,
  23                                 'digit'         => DEFAULT_OFF,
  24                                 'parenthesis'   => DEFAULT_OFF,
  25                                 'deprecated'    => DEFAULT_OFF,
  26                                 'printf'        => DEFAULT_OFF,
  27                                 'prototype'     => DEFAULT_OFF,
  28                                 'qw'            => DEFAULT_OFF,
  29                            },
  30         'severe'        => {    'inplace'       => DEFAULT_ON,
  31                                 'internal'      => DEFAULT_ON,
  32                                 'debugging'     => DEFAULT_ON,
  33                                 'malloc'        => DEFAULT_ON,
  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         'regexp'        => DEFAULT_OFF,
  43         'glob'          => DEFAULT_OFF,
  44         'y2k'           => DEFAULT_OFF,
  45         'chmod'         => DEFAULT_OFF,
  46         'umask'         => DEFAULT_OFF,
  47         'untie'         => DEFAULT_OFF,
  48         'substr'        => DEFAULT_OFF,
  49         'taint'         => DEFAULT_OFF,
  50         'signal'        => DEFAULT_OFF,
  51         'closure'       => DEFAULT_OFF,
  52         'overflow'      => DEFAULT_OFF,
  53         'portable'      => DEFAULT_OFF,
  54         'utf8'          => DEFAULT_OFF,
  55         'exiting'       => DEFAULT_OFF,
  56         'pack'          => DEFAULT_OFF,
  57         'unpack'        => DEFAULT_OFF,
  58          #'default'     => DEFAULT_ON,
  59         } ;
  60
  61
  62 ###########################################################################
  63 sub tab {
  64     my($l, $t) = @_;
  65     $t .= "\t" x ($l - (length($t) + 1) / 8);
  66     $t;
  67 }
  68
  69 ###########################################################################
  70
  71 my %list ;
  72 my %Value ;
  73 my $index = 0 ;
  74
  75 sub walk
  76 {
  77     my $tre = shift ;
  78     my @list = () ;
  79     my ($k, $v) ;
  80
  81     foreach $k (sort keys %$tre) {
  82         $v = $tre->{$k};
  83         die "duplicate key $k\n" if defined $list{$k} ;
  84         $Value{$index} = uc $k ;
  85         push @{ $list{$k} }, $index ++ ;
  86         if (ref $v)
  87           { push (@{ $list{$k} }, walk ($v)) }
  88         push @list, @{ $list{$k} } ;
  89     }
  90
  91    return @list ;
  92 }
  93
  94 ###########################################################################
  95
  96 sub mkRange
  97 {
  98     my @a = @_ ;
  99     my @out = @a ;
 100     my $i ;
 101
 102
 103     for ($i = 1 ; $i < @a; ++ $i) {
 104         $out[$i] = ".."
 105           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
 106     }
 107
 108     my $out = join(",",@out);
 109
 110     $out =~ s/,(\.\.,)+/../g ;
 111     return $out;
 112 }
 113
 114 ###########################################################################
 115 sub printTree
 116 {
 117     my $tre = shift ;
 118     my $prefix = shift ;
 119     my $indent = shift ;
 120     my ($k, $v) ;
 121
 122     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
 123
 124     $prefix .= " " x $indent ;
 125     foreach $k (sort keys %$tre) {
 126         $v = $tre->{$k};
 127         print $prefix . "|\n" ;
 128         print $prefix . "+- $k" ;
 129         if (ref $v)
 130         {
 131             print " " . "-" x ($max - length $k ) . "+\n" ;
 132             printTree ($v, $prefix . "|" , $max + $indent - 1)
 133         }
 134         else
 135           { print "\n" }
 136     }
 137
 138 }
 139
 140 ###########################################################################
 141
 142 sub mkHex
 143 {
 144     my ($max, @a) = @_ ;
 145     my $mask = "\x00" x $max ;
 146     my $string = "" ;
 147
 148     foreach (@a) {
 149         vec($mask, $_, 1) = 1 ;
 150     }
 151
 152     #$string = unpack("H$max", $mask) ;
 153     #$string =~ s/(..)/\x$1/g;
 154     foreach (unpack("C*", $mask)) {
 155         $string .= '\x' . sprintf("%2.2x", $_) ;
 156     }
 157     return $string ;
 158 }
 159
 160 ###########################################################################
 161
 162 if (@ARGV && $ARGV[0] eq "tree")
 163 {
 164     print "  all -+\n" ;
 165     printTree($tree, "   ", 4) ;
 166     exit ;
 167 }
 168
 169 #unlink "warnings.h";
 170 #unlink "lib/warnings.pm";
 171 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
 172 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
 173
 174 print WARN <<'EOM' ;
 175 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 176    This file is built by warnings.pl
 177    Any changes made here will be lost!
 178 */
 179
 180
 181 #define Off(x)                  ((x) / 8)
 182 #define Bit(x)                  (1 << ((x) % 8))
 183 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
 184
 185
 186 #define G_WARN_OFF              0       /* $^W == 0 */
 187 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
 188 #define G_WARN_ALL_ON           2       /* -W flag */
 189 #define G_WARN_ALL_OFF          4       /* -X flag */
 190 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
 191 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 192
 193 #define WARN_STD                Nullsv
 194 #define WARN_ALL                (Nullsv+1)      /* use warnings 'all' */
 195 #define WARN_NONE               (Nullsv+2)      /* no  warnings 'all' */
 196
 197 #define specialWARN(x)          ((x) == WARN_STD || (x) == WARN_ALL ||  \
 198                                  (x) == WARN_NONE)
 199
 200 #define ckDEAD(x)                                                       \
 201            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 202             IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
 203
 204 #define ckWARN(x)                                                       \
 205         ( (PL_curcop->cop_warnings != WARN_STD &&                       \
 206            PL_curcop->cop_warnings != WARN_NONE &&                      \
 207               (PL_curcop->cop_warnings == WARN_ALL ||                   \
 208                IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )           \
 209           || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
 210
 211 #define ckWARN2(x,y)                                                    \
 212           ( (PL_curcop->cop_warnings != WARN_STD  &&                    \
 213              PL_curcop->cop_warnings != WARN_NONE &&                    \
 214               (PL_curcop->cop_warnings == WARN_ALL ||                   \
 215                 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||          \
 216                 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) )          \
 217             ||  (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
 218
 219 #define ckWARN_d(x)                                                     \
 220           (PL_curcop->cop_warnings == WARN_STD ||                       \
 221            PL_curcop->cop_warnings == WARN_ALL ||                       \
 222              (PL_curcop->cop_warnings != WARN_NONE &&                   \
 223               IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
 224
 225 #define ckWARN2_d(x,y)                                                  \
 226           (PL_curcop->cop_warnings == WARN_STD ||                       \
 227            PL_curcop->cop_warnings == WARN_ALL ||                       \
 228              (PL_curcop->cop_warnings != WARN_NONE &&                   \
 229                 (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||         \
 230                  IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
 231
 232
 233 #define isLEXWARN_on    (PL_curcop->cop_warnings != WARN_STD)
 234 #define isLEXWARN_off   (PL_curcop->cop_warnings == WARN_STD)
 235 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 236 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
 237
 238 EOM
 239
 240
 241 $index = 0 ;
 242 @{ $list{"all"} } = walk ($tree) ;
 243
 244 $index *= 2 ;
 245 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 246
 247 my $k ;
 248 foreach $k (sort { $a <=> $b } keys %Value) {
 249     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
 250 }
 251 print WARN "\n" ;
 252
 253 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
 254 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 255 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 256 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
 257
 258 print WARN <<'EOM';
 259
 260 /* end of file warnings.h */
 261
 262 EOM
 263
 264 close WARN ;
 265
 266 while (<DATA>) {
 267     last if /^KEYWORDS$/ ;
 268     print PM $_ ;
 269 }
 270
 271 $list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
 272 print PM "%Bits = (\n" ;
 273 foreach $k (sort keys  %list) {
 274
 275     my $v = $list{$k} ;
 276     my @list = sort { $a <=> $b } @$v ;
 277
 278     print PM tab(4, "    '$k'"), '=> "',
 279                 # mkHex($warn_size, @list),
 280                 mkHex($warn_size, map $_ * 2 , @list),
 281                 '", # [', mkRange(@list), "]\n" ;
 282 }
 283
 284 print PM "  );\n\n" ;
 285
 286 print PM "%DeadBits = (\n" ;
 287 foreach $k (sort keys  %list) {
 288
 289     my $v = $list{$k} ;
 290     my @list = sort { $a <=> $b } @$v ;
 291
 292     print PM tab(4, "    '$k'"), '=> "',
 293                 # mkHex($warn_size, @list),
 294                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 295                 '", # [', mkRange(@list), "]\n" ;
 296 }
 297
 298 print PM "  );\n\n" ;
 299 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
 300 while (<DATA>) {
 301     print PM $_ ;
 302 }
 303
 304 close PM ;
 305
 306 __END__
 307
 308 # This file was created by warnings.pl
 309 # Any changes made here will be lost.
 310 #
 311
 312 package warnings;
 313
 314 =head1 NAME
 315
 316 warnings - Perl pragma to control optional warnings
 317
 318 =head1 SYNOPSIS
 319
 320     use warnings;
 321     no warnings;
 322
 323     use warnings "all";
 324     no warnings "all";
 325
 326     if (warnings::enabled("void") {
 327         warnings::warn("void", "some warning");
 328     }
 329
 330 =head1 DESCRIPTION
 331
 332 If no import list is supplied, all possible warnings are either enabled
 333 or disabled.
 334
 335 Two functions are provided to assist module authors.
 336
 337 =over 4
 338
 339 =item warnings::enabled($category)
 340
 341 Returns TRUE if the warnings category in C<$category> is enabled in the
 342 calling module. Otherwise returns FALSE.
 343
 344
 345 =item warnings::warn($category, $message)
 346
 347 If the calling module has I<not> set C<$category> to "FATAL", print
 348 C<$message> to STDERR.
 349 If the calling module has set C<$category> to "FATAL", print C<$message>
 350 STDERR then die.
 351
 352 =back
 353
 354 See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
 355
 356 =cut
 357
 358 use Carp ;
 359
 360 KEYWORDS
 361
 362 sub bits {
 363     my $mask ;
 364     my $catmask ;
 365     my $fatal = 0 ;
 366     foreach my $word (@_) {
 367         if  ($word eq 'FATAL') {
 368             $fatal = 1;
 369         }
 370         else {
 371             if ($catmask = $Bits{$word}) {
 372                 $mask |= $catmask ;
 373                 $mask |= $DeadBits{$word} if $fatal ;
 374             }
 375         }
 376     }
 377
 378     return $mask ;
 379 }
 380
 381 sub import {
 382     shift;
 383     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
 384 }
 385
 386 sub unimport {
 387     shift;
 388     ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
 389 }
 390
 391 sub enabled
 392 {
 393     # If no parameters, check for any lexical warnings enabled
 394     # in the users scope.
 395     my $callers_bitmask = (caller(1))[9] ;
 396     return ($callers_bitmask ne $NONE) if @_ == 0 ;
 397
 398     # otherwise check for the category supplied.
 399     my $category = shift ;
 400     return 0
 401         unless $Bits{$category} ;
 402     return 0 unless defined $callers_bitmask ;
 403     return 1
 404         if ($callers_bitmask & $Bits{$category}) ne $NONE ;
 405
 406     return 0 ;
 407 }
 408
 409 sub warn
 410 {
 411     croak "Usage: warnings::warn('category', 'message')"
 412         unless @_ == 2 ;
 413     my $category = shift ;
 414     my $message = shift ;
 415     local $Carp::CarpLevel = 1 ;
 416     my $callers_bitmask = (caller(1))[9] ;
 417     croak($message)
 418         if defined $callers_bitmask &&
 419            ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
 420     carp($message) ;
 421 }
 422
 423 1;