warnings.pl

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