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