warnings.pl

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