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 EOM
 203
 204 my $offset = 0 ;
 205
 206 $index = $offset ;
 207 #@{ $list{"all"} } = walk ($tree) ;
 208 walk ($tree) ;
 209
 210
 211 $index *= 2 ;
 212 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 213
 214 my $k ;
 215 foreach $k (sort { $a <=> $b } keys %Value) {
 216     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
 217 }
 218 print WARN "\n" ;
 219
 220 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
 221 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 222 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 223 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
 224
 225 print WARN <<'EOM';
 226
 227 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
 228 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
 229 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 230 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
 231 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
 232
 233 #define ckDEAD(x)                                                       \
 234            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 235             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
 236               isWARNf_on(PL_curcop->cop_warnings, x)))
 237
 238 #define ckWARN(x)                                                       \
 239         ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&     \
 240               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 241                isWARN_on(PL_curcop->cop_warnings, x) ) )                \
 242           || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 243
 244 #define ckWARN2(x,y)                                                    \
 245           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 246               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 247                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 248                 isWARN_on(PL_curcop->cop_warnings, y) ) )               \
 249             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 250
 251 #define ckWARN_d(x)                                                     \
 252           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 253              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 254               isWARN_on(PL_curcop->cop_warnings, x) ) )
 255
 256 #define ckWARN2_d(x,y)                                                  \
 257           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 258              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 259                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 260                  isWARN_on(PL_curcop->cop_warnings, y) ) ) )
 261
 262 /* end of file warnings.h */
 263
 264 EOM
 265
 266 close WARN ;
 267
 268 while (<DATA>) {
 269     last if /^KEYWORDS$/ ;
 270     print PM $_ ;
 271 }
 272
 273 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
 274
 275 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
 276
 277 print PM "%Offsets = (\n" ;
 278 foreach my $k (sort { $a <=> $b } keys %Value) {
 279     my $v = lc $Value{$k} ;
 280     $k *= 2 ;
 281     print PM tab(4, "    '$v'"), "=> $k,\n" ;
 282 }
 283
 284 print PM "  );\n\n" ;
 285
 286 print PM "%Bits = (\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 , @list),
 295                 '", # [', mkRange(@list), "]\n" ;
 296 }
 297
 298 print PM "  );\n\n" ;
 299
 300 print PM "%DeadBits = (\n" ;
 301 foreach $k (sort keys  %list) {
 302
 303     my $v = $list{$k} ;
 304     my @list = sort { $a <=> $b } @$v ;
 305
 306     print PM tab(4, "    '$k'"), '=> "',
 307                 # mkHex($warn_size, @list),
 308                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 309                 '", # [', mkRange(@list), "]\n" ;
 310 }
 311
 312 print PM "  );\n\n" ;
 313 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
 314 print PM '$LAST_BIT = ' . "$index ;\n" ;
 315 print PM '$BYTES    = ' . "$warn_size ;\n" ;
 316 while (<DATA>) {
 317     print PM $_ ;
 318 }
 319
 320 close PM ;
 321
 322 __END__
 323
 324 # This file was created by warnings.pl
 325 # Any changes made here will be lost.
 326 #
 327
 328 package warnings;
 329
 330 =head1 NAME
 331
 332 warnings - Perl pragma to control optional warnings
 333
 334 =head1 SYNOPSIS
 335
 336     use warnings;
 337     no warnings;
 338
 339     use warnings "all";
 340     no warnings "all";
 341
 342     use warnings::register;
 343     if (warnings::enabled()) {
 344         warnings::warn("some warning");
 345     }
 346
 347     if (warnings::enabled("void")) {
 348         warnings::warn("void", "some warning");
 349     }
 350
 351 =head1 DESCRIPTION
 352
 353 If no import list is supplied, all possible warnings are either enabled
 354 or disabled.
 355
 356 A number of functions are provided to assist module authors.
 357
 358 =over 4
 359
 360 =item use warnings::register
 361
 362 Creates a new warnings category which has the same name as the module
 363 where the call to the pragma is used.
 364
 365 =item warnings::enabled([$category])
 366
 367 Returns TRUE if the warnings category C<$category> is enabled in the
 368 calling module.  Otherwise returns FALSE.
 369
 370 If the parameter, C<$category>, isn't supplied, the current package name
 371 will be used.
 372
 373 =item warnings::warn([$category,] $message)
 374
 375 If the calling module has I<not> set C<$category> to "FATAL", print
 376 C<$message> to STDERR.
 377 If the calling module has set C<$category> to "FATAL", print C<$message>
 378 STDERR then die.
 379
 380 If the parameter, C<$category>, isn't supplied, the current package name
 381 will be used.
 382
 383 =back
 384
 385 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 386
 387 =cut
 388
 389 use Carp ;
 390
 391 KEYWORDS
 392
 393 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 394
 395 sub bits {
 396     my $mask ;
 397     my $catmask ;
 398     my $fatal = 0 ;
 399     foreach my $word (@_) {
 400         if  ($word eq 'FATAL') {
 401             $fatal = 1;
 402         }
 403         elsif ($catmask = $Bits{$word}) {
 404             $mask |= $catmask ;
 405             $mask |= $DeadBits{$word} if $fatal ;
 406         }
 407         else
 408           { croak("unknown warnings category '$word'")}
 409     }
 410
 411     return $mask ;
 412 }
 413
 414 sub import {
 415     shift;
 416     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
 417 }
 418
 419 sub unimport {
 420     shift;
 421     my $mask = ${^WARNING_BITS} ;
 422     if (vec($mask, $Offsets{'all'}, 1)) {
 423         $mask = $Bits{'all'} ;
 424         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 425     }
 426     ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
 427 }
 428
 429 sub enabled
 430 {
 431     croak("Usage: warnings::enabled([category])")
 432         unless @_ == 1 || @_ == 0 ;
 433     local $Carp::CarpLevel = 1 ;
 434     my $category ;
 435     my $offset ;
 436     my $callers_bitmask = (caller(1))[9] ;
 437     return 0 unless defined $callers_bitmask ;
 438
 439
 440     if (@_) {
 441         # check the category supplied.
 442         $category = shift ;
 443         $offset = $Offsets{$category};
 444         croak("unknown warnings category '$category'")
 445             unless defined $offset;
 446     }
 447     else {
 448         $category = (caller(0))[0] ;
 449         $offset = $Offsets{$category};
 450         croak("package '$category' not registered for warnings")
 451             unless defined $offset ;
 452     }
 453
 454     return vec($callers_bitmask, $offset, 1) ||
 455            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 456 }
 457
 458
 459 sub warn
 460 {
 461     croak("Usage: warnings::warn([category,] 'message')")
 462         unless @_ == 2 || @_ == 1 ;
 463     local $Carp::CarpLevel = 1 ;
 464     my $category ;
 465     my $offset ;
 466     my $callers_bitmask = (caller(1))[9] ;
 467
 468     if (@_ == 2) {
 469         $category = shift ;
 470         $offset = $Offsets{$category};
 471         croak("unknown warnings category '$category'")
 472             unless defined $offset ;
 473     }
 474     else {
 475         $category = (caller(0))[0] ;
 476         $offset = $Offsets{$category};
 477         croak("package '$category' not registered for warnings")
 478             unless defined $offset ;
 479     }
 480
 481     my $message = shift ;
 482     croak($message)
 483         if vec($callers_bitmask, $offset+1, 1) ||
 484            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 485     carp($message) ;
 486 }
 487
 488 1;