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