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