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     if (warnings::enabled($object)) {
 352         warnings::warn($object, "some warning");
 353     }
 354
 355     warnif("some warning");
 356     warnif("void", "some warning");
 357     warnif($object, "some warning");
 358
 359 =head1 DESCRIPTION
 360
 361 If no import list is supplied, all possible warnings are either enabled
 362 or disabled.
 363
 364 A number of functions are provided to assist module authors.
 365
 366 =over 4
 367
 368 =item use warnings::register
 369
 370 Creates a new warnings category with the same name as the package where
 371 the call to the pragma is used.
 372
 373 =item warnings::enabled()
 374
 375 Use the warnings category with the same name as the current package.
 376
 377 Return TRUE if that warnings category is enabled in the calling module.
 378 Otherwise returns FALSE.
 379
 380 =item warnings::enabled($category)
 381
 382 Return TRUE if the warnings category, C<$category>, is enabled in the
 383 calling module.
 384 Otherwise returns FALSE.
 385
 386 =item warnings::enabled($object)
 387
 388 Use the name of the class for the object reference, C<$object>, as the
 389 warnings category.
 390
 391 Return TRUE if that warnings category is enabled in the first scope
 392 where the object is used.
 393 Otherwise returns FALSE.
 394
 395 =item warnings::warn($message)
 396
 397 Print C<$message> to STDERR.
 398
 399 Use the warnings category with the same name as the current package.
 400
 401 If that warnings category has been set to "FATAL" in the calling module
 402 then die. Otherwise return.
 403
 404 =item warnings::warn($category, $message)
 405
 406 Print C<$message> to STDERR.
 407
 408 If the warnings category, C<$category>, has been set to "FATAL" in the
 409 calling module then die. Otherwise return.
 410
 411 =item warnings::warn($object, $message)
 412
 413 Print C<$message> to STDERR.
 414
 415 Use the name of the class for the object reference, C<$object>, as the
 416 warnings category.
 417
 418 If that warnings category has been set to "FATAL" in the scope where C<$object>
 419 is first used then die. Otherwise return.
 420
 421
 422 =item warnings::warnif($message)
 423
 424 Equivalent to:
 425
 426     if (warnings::enabled())
 427       { warnings::warn($message) }
 428
 429 =item warnings::warnif($category, $message)
 430
 431 Equivalent to:
 432
 433     if (warnings::enabled($category))
 434       { warnings::warn($category, $message) }
 435
 436 =item warnings::warnif($object, $message)
 437
 438 Equivalent to:
 439
 440     if (warnings::enabled($object))
 441       { warnings::warn($object, $message) }
 442
 443 =back
 444
 445 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 446
 447 =cut
 448
 449 use Carp ;
 450
 451 KEYWORDS
 452
 453 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 454
 455 sub bits {
 456     my $mask ;
 457     my $catmask ;
 458     my $fatal = 0 ;
 459     foreach my $word (@_) {
 460         if  ($word eq 'FATAL') {
 461             $fatal = 1;
 462         }
 463         elsif ($catmask = $Bits{$word}) {
 464             $mask |= $catmask ;
 465             $mask |= $DeadBits{$word} if $fatal ;
 466         }
 467         else
 468           { croak("unknown warnings category '$word'")}
 469     }
 470
 471     return $mask ;
 472 }
 473
 474 sub import {
 475     shift;
 476     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
 477 }
 478
 479 sub unimport {
 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') | $All) ;
 487 }
 488
 489 sub __chk
 490 {
 491     my $category ;
 492     my $offset ;
 493     my $isobj = 0 ;
 494
 495     if (@_) {
 496         # check the category supplied.
 497         $category = shift ;
 498         if (ref $category) {
 499             croak ("not an object")
 500                 if $category !~ /^([^=]+)=/ ;+
 501             $category = $1 ;
 502             $isobj = 1 ;
 503         }
 504         $offset = $Offsets{$category};
 505         croak("unknown warnings category '$category'")
 506             unless defined $offset;
 507     }
 508     else {
 509         $category = (caller(1))[0] ;
 510         $offset = $Offsets{$category};
 511         croak("package '$category' not registered for warnings")
 512             unless defined $offset ;
 513     }
 514
 515     my $this_pkg = (caller(1))[0] ;
 516     my $i = 2 ;
 517     my $pkg ;
 518
 519     if ($isobj) {
 520         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 521             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 522         }
 523         $i -= 2 ;
 524     }
 525     else {
 526         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 527             last if $pkg ne $this_pkg ;
 528         }
 529         $i = 2
 530             if !$pkg || $pkg eq $this_pkg ;
 531     }
 532
 533     my $callers_bitmask = (caller($i))[9] ;
 534     return ($callers_bitmask, $offset, $i) ;
 535 }
 536
 537 sub enabled
 538 {
 539     croak("Usage: warnings::enabled([category])")
 540         unless @_ == 1 || @_ == 0 ;
 541
 542     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 543
 544     return 0 unless defined $callers_bitmask ;
 545     return vec($callers_bitmask, $offset, 1) ||
 546            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 547 }
 548
 549
 550 sub warn
 551 {
 552     croak("Usage: warnings::warn([category,] 'message')")
 553         unless @_ == 2 || @_ == 1 ;
 554
 555     my $message = pop ;
 556     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 557     local $Carp::CarpLevel = $i ;
 558     croak($message)
 559         if vec($callers_bitmask, $offset+1, 1) ||
 560            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 561     carp($message) ;
 562 }
 563
 564 sub warnif
 565 {
 566     croak("Usage: warnings::warnif([category,] 'message')")
 567         unless @_ == 2 || @_ == 1 ;
 568
 569     my $message = pop ;
 570     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 571     local $Carp::CarpLevel = $i ;
 572
 573     return
 574         unless defined $callers_bitmask &&
 575                 (vec($callers_bitmask, $offset, 1) ||
 576                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 577
 578     croak($message)
 579         if vec($callers_bitmask, $offset+1, 1) ||
 580            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 581
 582     carp($message) ;
 583 }
 584 1;