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