warnings.pl

   1 #!/usr/bin/perl
   2
   3 $VERSION = '1.02';
   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' => [ 5.008, {
  16         'io'            => [ 5.008, {
  17                                 'pipe'          => [ 5.008, DEFAULT_OFF],
  18                                 'unopened'      => [ 5.008, DEFAULT_OFF],
  19                                 'closed'        => [ 5.008, DEFAULT_OFF],
  20                                 'newline'       => [ 5.008, DEFAULT_OFF],
  21                                 'exec'          => [ 5.008, DEFAULT_OFF],
  22                                 'layer'         => [ 5.008, DEFAULT_OFF],
  23                            }],
  24         'syntax'        => [ 5.008, {
  25                                 'ambiguous'     => [ 5.008, DEFAULT_OFF],
  26                                 'semicolon'     => [ 5.008, DEFAULT_OFF],
  27                                 'precedence'    => [ 5.008, DEFAULT_OFF],
  28                                 'bareword'      => [ 5.008, DEFAULT_OFF],
  29                                 'reserved'      => [ 5.008, DEFAULT_OFF],
  30                                 'digit'         => [ 5.008, DEFAULT_OFF],
  31                                 'parenthesis'   => [ 5.008, DEFAULT_OFF],
  32                                 'printf'        => [ 5.008, DEFAULT_OFF],
  33                                 'prototype'     => [ 5.008, DEFAULT_OFF],
  34                                 'qw'            => [ 5.008, DEFAULT_OFF],
  35                            }],
  36         'severe'        => [ 5.008, {
  37                                 'inplace'       => [ 5.008, DEFAULT_ON],
  38                                 'internal'      => [ 5.008, DEFAULT_ON],
  39                                 'debugging'     => [ 5.008, DEFAULT_ON],
  40                                 'malloc'        => [ 5.008, DEFAULT_ON],
  41                            }],
  42         'deprecated'    => [ 5.008, DEFAULT_OFF],
  43         'void'          => [ 5.008, DEFAULT_OFF],
  44         'recursion'     => [ 5.008, DEFAULT_OFF],
  45         'redefine'      => [ 5.008, DEFAULT_OFF],
  46         'numeric'       => [ 5.008, DEFAULT_OFF],
  47         'uninitialized' => [ 5.008, DEFAULT_OFF],
  48         'once'          => [ 5.008, DEFAULT_OFF],
  49         'misc'          => [ 5.008, DEFAULT_OFF],
  50         'regexp'        => [ 5.008, DEFAULT_OFF],
  51         'glob'          => [ 5.008, DEFAULT_OFF],
  52         'untie'         => [ 5.008, DEFAULT_OFF],
  53         'substr'        => [ 5.008, DEFAULT_OFF],
  54         'taint'         => [ 5.008, DEFAULT_OFF],
  55         'signal'        => [ 5.008, DEFAULT_OFF],
  56         'closure'       => [ 5.008, DEFAULT_OFF],
  57         'overflow'      => [ 5.008, DEFAULT_OFF],
  58         'portable'      => [ 5.008, DEFAULT_OFF],
  59         'utf8'          => [ 5.008, DEFAULT_OFF],
  60         'exiting'       => [ 5.008, DEFAULT_OFF],
  61         'pack'          => [ 5.008, DEFAULT_OFF],
  62         'unpack'        => [ 5.008, DEFAULT_OFF],
  63         'threads'       => [ 5.008, DEFAULT_OFF],
  64         'assertions'    => [ 5.009, DEFAULT_OFF],
  65
  66          #'default'     => [ 5.008, DEFAULT_ON ],
  67         }],
  68 } ;
  69
  70 ###########################################################################
  71 sub tab {
  72     my($l, $t) = @_;
  73     $t .= "\t" x ($l - (length($t) + 1) / 8);
  74     $t;
  75 }
  76
  77 ###########################################################################
  78
  79 my %list ;
  80 my %Value ;
  81 my %ValueToName ;
  82 my %NameToValue ;
  83 my $index ;
  84
  85 my %v_list = () ;
  86
  87 sub valueWalk
  88 {
  89     my $tre = shift ;
  90     my @list = () ;
  91     my ($k, $v) ;
  92
  93     foreach $k (sort keys %$tre) {
  94         $v = $tre->{$k};
  95         die "duplicate key $k\n" if defined $list{$k} ;
  96         die "Value associated with key '$k' is not an ARRAY reference"
  97             if !ref $v || ref $v ne 'ARRAY' ;
  98
  99         my ($ver, $rest) = @{ $v } ;
 100         push @{ $v_list{$ver} }, $k;
 101
 102         if (ref $rest)
 103           { valueWalk ($rest) }
 104
 105     }
 106
 107 }
 108
 109 sub orderValues
 110 {
 111     my $index = 0;
 112     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
 113         foreach my $name (@{ $v_list{$ver} } ) {
 114             $ValueToName{ $index } = [ uc $name, $ver ] ;
 115             $NameToValue{ uc $name } = $index ++ ;
 116         }
 117     }
 118
 119     return $index ;
 120 }
 121
 122 ###########################################################################
 123
 124 sub walk
 125 {
 126     my $tre = shift ;
 127     my @list = () ;
 128     my ($k, $v) ;
 129
 130     foreach $k (sort keys %$tre) {
 131         $v = $tre->{$k};
 132         die "duplicate key $k\n" if defined $list{$k} ;
 133         #$Value{$index} = uc $k ;
 134         die "Can't find key '$k'"
 135             if ! defined $NameToValue{uc $k} ;
 136         push @{ $list{$k} }, $NameToValue{uc $k} ;
 137         die "Value associated with key '$k' is not an ARRAY reference"
 138             if !ref $v || ref $v ne 'ARRAY' ;
 139
 140         my ($ver, $rest) = @{ $v } ;
 141         if (ref $rest)
 142           { push (@{ $list{$k} }, walk ($rest)) }
 143
 144         push @list, @{ $list{$k} } ;
 145     }
 146
 147    return @list ;
 148 }
 149
 150 ###########################################################################
 151
 152 sub mkRange
 153 {
 154     my @a = @_ ;
 155     my @out = @a ;
 156     my $i ;
 157
 158
 159     for ($i = 1 ; $i < @a; ++ $i) {
 160         $out[$i] = ".."
 161           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
 162     }
 163
 164     my $out = join(",",@out);
 165
 166     $out =~ s/,(\.\.,)+/../g ;
 167     return $out;
 168 }
 169
 170 ###########################################################################
 171 sub printTree
 172 {
 173     my $tre = shift ;
 174     my $prefix = shift ;
 175     my ($k, $v) ;
 176
 177     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
 178     my @keys = sort keys %$tre ;
 179
 180     while ($k = shift @keys) {
 181         $v = $tre->{$k};
 182         die "Value associated with key '$k' is not an ARRAY reference"
 183             if !ref $v || ref $v ne 'ARRAY' ;
 184
 185         my $offset ;
 186         if ($tre ne $tree) {
 187             print $prefix . "|\n" ;
 188             print $prefix . "+- $k" ;
 189             $offset = ' ' x ($max + 4) ;
 190         }
 191         else {
 192             print $prefix . "$k" ;
 193             $offset = ' ' x ($max + 1) ;
 194         }
 195
 196         my ($ver, $rest) = @{ $v } ;
 197         if (ref $rest)
 198         {
 199             my $bar = @keys ? "|" : " ";
 200             print " -" . "-" x ($max - length $k ) . "+\n" ;
 201             printTree ($rest, $prefix . $bar . $offset )
 202         }
 203         else
 204           { print "\n" }
 205     }
 206
 207 }
 208
 209 ###########################################################################
 210
 211 sub mkHexOct
 212 {
 213     my ($f, $max, @a) = @_ ;
 214     my $mask = "\x00" x $max ;
 215     my $string = "" ;
 216
 217     foreach (@a) {
 218         vec($mask, $_, 1) = 1 ;
 219     }
 220
 221     foreach (unpack("C*", $mask)) {
 222         if ($f eq 'x') {
 223             $string .= '\x' . sprintf("%2.2x", $_)
 224         }
 225         else {
 226             $string .= '\\' . sprintf("%o", $_)
 227         }
 228     }
 229     return $string ;
 230 }
 231
 232 sub mkHex
 233 {
 234     my($max, @a) = @_;
 235     return mkHexOct("x", $max, @a);
 236 }
 237
 238 sub mkOct
 239 {
 240     my($max, @a) = @_;
 241     return mkHexOct("o", $max, @a);
 242 }
 243
 244 ###########################################################################
 245
 246 if (@ARGV && $ARGV[0] eq "tree")
 247 {
 248     printTree($tree, "    ") ;
 249     exit ;
 250 }
 251
 252 unlink "warnings.h";
 253 unlink "lib/warnings.pm";
 254 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
 255 binmode WARN;
 256 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
 257 binmode PM;
 258
 259 print WARN <<'EOM' ;
 260 /* -*- buffer-read-only: t -*-
 261    !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 262    This file is built by warnings.pl
 263    Any changes made here will be lost!
 264 */
 265
 266
 267 #define Off(x)                  ((x) / 8)
 268 #define Bit(x)                  (1 << ((x) % 8))
 269 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
 270
 271
 272 #define G_WARN_OFF              0       /* $^W == 0 */
 273 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
 274 #define G_WARN_ALL_ON           2       /* -W flag */
 275 #define G_WARN_ALL_OFF          4       /* -X flag */
 276 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
 277 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 278
 279 #define pWARN_STD               Nullsv
 280 #define pWARN_ALL               (Nullsv+1)      /* use warnings 'all' */
 281 #define pWARN_NONE              (Nullsv+2)      /* no  warnings 'all' */
 282
 283 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
 284                                  (x) == pWARN_NONE)
 285 EOM
 286
 287 my $offset = 0 ;
 288
 289 $index = $offset ;
 290 #@{ $list{"all"} } = walk ($tree) ;
 291 valueWalk ($tree) ;
 292 my $index = orderValues();
 293
 294 die <<EOM if $index > 255 ;
 295 Too many warnings categories -- max is 255
 296     rewrite packWARN* & unpackWARN* macros
 297 EOM
 298
 299 walk ($tree) ;
 300
 301 $index *= 2 ;
 302 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 303
 304 my $k ;
 305 my $last_ver = 0;
 306 foreach $k (sort { $a <=> $b } keys %ValueToName) {
 307     my ($name, $version) = @{ $ValueToName{$k} };
 308     print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
 309         if $last_ver != $version ;
 310     print WARN tab(5, "#define WARN_$name"), "$k\n" ;
 311     $last_ver = $version ;
 312 }
 313 print WARN "\n" ;
 314
 315 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
 316 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 317 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 318 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
 319 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
 320
 321 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
 322
 323 print WARN <<'EOM';
 324
 325 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
 326 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
 327 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 328 #define isWARN_on(c,x)  (IsSet(SvPVX_const(c), 2*(x)))
 329 #define isWARNf_on(c,x) (IsSet(SvPVX_const(c), 2*(x)+1))
 330
 331 #define ckWARN(x)                                                       \
 332         ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&     \
 333               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 334                isWARN_on(PL_curcop->cop_warnings, x) ) )                \
 335           || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 336
 337 #define ckWARN2(x,y)                                                    \
 338           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 339               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 340                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 341                 isWARN_on(PL_curcop->cop_warnings, y) ) )               \
 342             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 343
 344 #define ckWARN3(x,y,z)                                                  \
 345           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 346               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 347                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 348                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
 349                 isWARN_on(PL_curcop->cop_warnings, z) ) )               \
 350             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 351
 352 #define ckWARN4(x,y,z,t)                                                \
 353           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 354               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 355                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 356                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
 357                 isWARN_on(PL_curcop->cop_warnings, z)  ||               \
 358                 isWARN_on(PL_curcop->cop_warnings, t) ) )               \
 359             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 360
 361 #define ckWARN_d(x)                                                     \
 362           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 363              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 364               isWARN_on(PL_curcop->cop_warnings, x) ) )
 365
 366 #define ckWARN2_d(x,y)                                                  \
 367           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 368              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 369                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 370                  isWARN_on(PL_curcop->cop_warnings, y) ) ) )
 371
 372 #define ckWARN3_d(x,y,z)                                                \
 373           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 374              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 375                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 376                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
 377                  isWARN_on(PL_curcop->cop_warnings, z) ) ) )
 378
 379 #define ckWARN4_d(x,y,z,t)                                              \
 380           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 381              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 382                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 383                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
 384                  isWARN_on(PL_curcop->cop_warnings, z)  ||              \
 385                  isWARN_on(PL_curcop->cop_warnings, t) ) ) )
 386
 387 #define packWARN(a)             (a                                 )
 388 #define packWARN2(a,b)          ((a) | (b)<<8                      )
 389 #define packWARN3(a,b,c)        ((a) | (b)<<8 | (c) <<16           )
 390 #define packWARN4(a,b,c,d)      ((a) | (b)<<8 | (c) <<16 | (d) <<24)
 391
 392 #define unpackWARN1(x)          ((x)        & 0xFF)
 393 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
 394 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
 395 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
 396
 397 #define ckDEAD(x)                                                       \
 398            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 399             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
 400               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
 401               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
 402               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
 403               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
 404
 405 /* end of file warnings.h */
 406 /* ex: set ro: */
 407 EOM
 408
 409 close WARN ;
 410
 411 while (<DATA>) {
 412     last if /^KEYWORDS$/ ;
 413     print PM $_ ;
 414 }
 415
 416 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
 417
 418 $last_ver = 0;
 419 print PM "our %Offsets = (\n" ;
 420 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
 421     my ($name, $version) = @{ $ValueToName{$k} };
 422     $name = lc $name;
 423     $k *= 2 ;
 424     if ( $last_ver != $version ) {
 425         print PM "\n";
 426         print PM tab(4, "    # Warnings Categories added in Perl $version");
 427         print PM "\n\n";
 428     }
 429     print PM tab(4, "    '$name'"), "=> $k,\n" ;
 430     $last_ver = $version;
 431 }
 432
 433 print PM "  );\n\n" ;
 434
 435 print PM "our %Bits = (\n" ;
 436 foreach $k (sort keys  %list) {
 437
 438     my $v = $list{$k} ;
 439     my @list = sort { $a <=> $b } @$v ;
 440
 441     print PM tab(4, "    '$k'"), '=> "',
 442                 # mkHex($warn_size, @list),
 443                 mkHex($warn_size, map $_ * 2 , @list),
 444                 '", # [', mkRange(@list), "]\n" ;
 445 }
 446
 447 print PM "  );\n\n" ;
 448
 449 print PM "our %DeadBits = (\n" ;
 450 foreach $k (sort keys  %list) {
 451
 452     my $v = $list{$k} ;
 453     my @list = sort { $a <=> $b } @$v ;
 454
 455     print PM tab(4, "    '$k'"), '=> "',
 456                 # mkHex($warn_size, @list),
 457                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 458                 '", # [', mkRange(@list), "]\n" ;
 459 }
 460
 461 print PM "  );\n\n" ;
 462 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
 463 print PM '$LAST_BIT = ' . "$index ;\n" ;
 464 print PM '$BYTES    = ' . "$warn_size ;\n" ;
 465 while (<DATA>) {
 466     print PM $_ ;
 467 }
 468
 469 print PM "# ex: set ro:\n";
 470 close PM ;
 471
 472 __END__
 473 # -*- buffer-read-only: t -*-
 474 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 475 # This file was created by warnings.pl
 476 # Any changes made here will be lost.
 477 #
 478
 479 package warnings;
 480
 481 our $VERSION = '1.04';
 482
 483 =head1 NAME
 484
 485 warnings - Perl pragma to control optional warnings
 486
 487 =head1 SYNOPSIS
 488
 489     use warnings;
 490     no warnings;
 491
 492     use warnings "all";
 493     no warnings "all";
 494
 495     use warnings::register;
 496     if (warnings::enabled()) {
 497         warnings::warn("some warning");
 498     }
 499
 500     if (warnings::enabled("void")) {
 501         warnings::warn("void", "some warning");
 502     }
 503
 504     if (warnings::enabled($object)) {
 505         warnings::warn($object, "some warning");
 506     }
 507
 508     warnings::warnif("some warning");
 509     warnings::warnif("void", "some warning");
 510     warnings::warnif($object, "some warning");
 511
 512 =head1 DESCRIPTION
 513
 514 The C<warnings> pragma is a replacement for the command line flag C<-w>,
 515 but the pragma is limited to the enclosing block, while the flag is global.
 516 See L<perllexwarn> for more information.
 517
 518 If no import list is supplied, all possible warnings are either enabled
 519 or disabled.
 520
 521 A number of functions are provided to assist module authors.
 522
 523 =over 4
 524
 525 =item use warnings::register
 526
 527 Creates a new warnings category with the same name as the package where
 528 the call to the pragma is used.
 529
 530 =item warnings::enabled()
 531
 532 Use the warnings category with the same name as the current package.
 533
 534 Return TRUE if that warnings category is enabled in the calling module.
 535 Otherwise returns FALSE.
 536
 537 =item warnings::enabled($category)
 538
 539 Return TRUE if the warnings category, C<$category>, is enabled in the
 540 calling module.
 541 Otherwise returns FALSE.
 542
 543 =item warnings::enabled($object)
 544
 545 Use the name of the class for the object reference, C<$object>, as the
 546 warnings category.
 547
 548 Return TRUE if that warnings category is enabled in the first scope
 549 where the object is used.
 550 Otherwise returns FALSE.
 551
 552 =item warnings::warn($message)
 553
 554 Print C<$message> to STDERR.
 555
 556 Use the warnings category with the same name as the current package.
 557
 558 If that warnings category has been set to "FATAL" in the calling module
 559 then die. Otherwise return.
 560
 561 =item warnings::warn($category, $message)
 562
 563 Print C<$message> to STDERR.
 564
 565 If the warnings category, C<$category>, has been set to "FATAL" in the
 566 calling module then die. Otherwise return.
 567
 568 =item warnings::warn($object, $message)
 569
 570 Print C<$message> to STDERR.
 571
 572 Use the name of the class for the object reference, C<$object>, as the
 573 warnings category.
 574
 575 If that warnings category has been set to "FATAL" in the scope where C<$object>
 576 is first used then die. Otherwise return.
 577
 578
 579 =item warnings::warnif($message)
 580
 581 Equivalent to:
 582
 583     if (warnings::enabled())
 584       { warnings::warn($message) }
 585
 586 =item warnings::warnif($category, $message)
 587
 588 Equivalent to:
 589
 590     if (warnings::enabled($category))
 591       { warnings::warn($category, $message) }
 592
 593 =item warnings::warnif($object, $message)
 594
 595 Equivalent to:
 596
 597     if (warnings::enabled($object))
 598       { warnings::warn($object, $message) }
 599
 600 =back
 601
 602 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 603
 604 =cut
 605
 606 KEYWORDS
 607
 608 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 609
 610 sub Croaker
 611 {
 612     require Carp;
 613     delete $Carp::CarpInternal{'warnings'};
 614     Carp::croak(@_);
 615 }
 616
 617 sub bits
 618 {
 619     # called from B::Deparse.pm
 620
 621     push @_, 'all' unless @_;
 622
 623     my $mask;
 624     my $catmask ;
 625     my $fatal = 0 ;
 626     my $no_fatal = 0 ;
 627
 628     foreach my $word ( @_ ) {
 629         if ($word eq 'FATAL') {
 630             $fatal = 1;
 631             $no_fatal = 0;
 632         }
 633         elsif ($word eq 'NONFATAL') {
 634             $fatal = 0;
 635             $no_fatal = 1;
 636         }
 637         elsif ($catmask = $Bits{$word}) {
 638             $mask |= $catmask ;
 639             $mask |= $DeadBits{$word} if $fatal ;
 640             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 641         }
 642         else
 643           { Croaker("Unknown warnings category '$word'")}
 644     }
 645
 646     return $mask ;
 647 }
 648
 649 sub import
 650 {
 651     shift;
 652
 653     my $catmask ;
 654     my $fatal = 0 ;
 655     my $no_fatal = 0 ;
 656
 657     my $mask = ${^WARNING_BITS} ;
 658
 659     if (vec($mask, $Offsets{'all'}, 1)) {
 660         $mask |= $Bits{'all'} ;
 661         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 662     }
 663
 664     push @_, 'all' unless @_;
 665
 666     foreach my $word ( @_ ) {
 667         if ($word eq 'FATAL') {
 668             $fatal = 1;
 669             $no_fatal = 0;
 670         }
 671         elsif ($word eq 'NONFATAL') {
 672             $fatal = 0;
 673             $no_fatal = 1;
 674         }
 675         elsif ($catmask = $Bits{$word}) {
 676             $mask |= $catmask ;
 677             $mask |= $DeadBits{$word} if $fatal ;
 678             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 679         }
 680         else
 681           { Croaker("Unknown warnings category '$word'")}
 682     }
 683
 684     ${^WARNING_BITS} = $mask ;
 685 }
 686
 687 sub unimport
 688 {
 689     shift;
 690
 691     my $catmask ;
 692     my $mask = ${^WARNING_BITS} ;
 693
 694     if (vec($mask, $Offsets{'all'}, 1)) {
 695         $mask |= $Bits{'all'} ;
 696         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 697     }
 698
 699     push @_, 'all' unless @_;
 700
 701     foreach my $word ( @_ ) {
 702         if ($word eq 'FATAL') {
 703             next;
 704         }
 705         elsif ($catmask = $Bits{$word}) {
 706             $mask &= ~($catmask | $DeadBits{$word} | $All);
 707         }
 708         else
 709           { Croaker("Unknown warnings category '$word'")}
 710     }
 711
 712     ${^WARNING_BITS} = $mask ;
 713 }
 714
 715 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 716
 717 sub __chk
 718 {
 719     my $category ;
 720     my $offset ;
 721     my $isobj = 0 ;
 722
 723     if (@_) {
 724         # check the category supplied.
 725         $category = shift ;
 726         if (my $type = ref $category) {
 727             Croaker("not an object")
 728                 if exists $builtin_type{$type};
 729             $category = $type;
 730             $isobj = 1 ;
 731         }
 732         $offset = $Offsets{$category};
 733         Croaker("Unknown warnings category '$category'")
 734             unless defined $offset;
 735     }
 736     else {
 737         $category = (caller(1))[0] ;
 738         $offset = $Offsets{$category};
 739         Croaker("package '$category' not registered for warnings")
 740             unless defined $offset ;
 741     }
 742
 743     my $this_pkg = (caller(1))[0] ;
 744     my $i = 2 ;
 745     my $pkg ;
 746
 747     if ($isobj) {
 748         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 749             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 750         }
 751         $i -= 2 ;
 752     }
 753     else {
 754         $i = _error_loc(); # see where Carp will allocate the error
 755     }
 756
 757     my $callers_bitmask = (caller($i))[9] ;
 758     return ($callers_bitmask, $offset, $i) ;
 759 }
 760
 761 sub _error_loc {
 762     require Carp::Heavy;
 763     goto &Carp::short_error_loc; # don't introduce another stack frame
 764 }
 765
 766 sub enabled
 767 {
 768     Croaker("Usage: warnings::enabled([category])")
 769         unless @_ == 1 || @_ == 0 ;
 770
 771     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 772
 773     return 0 unless defined $callers_bitmask ;
 774     return vec($callers_bitmask, $offset, 1) ||
 775            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 776 }
 777
 778
 779 sub warn
 780 {
 781     Croaker("Usage: warnings::warn([category,] 'message')")
 782         unless @_ == 2 || @_ == 1 ;
 783
 784     my $message = pop ;
 785     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 786     require Carp;
 787     Carp::croak($message)
 788         if vec($callers_bitmask, $offset+1, 1) ||
 789            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 790     Carp::carp($message) ;
 791 }
 792
 793 sub warnif
 794 {
 795     Croaker("Usage: warnings::warnif([category,] 'message')")
 796         unless @_ == 2 || @_ == 1 ;
 797
 798     my $message = pop ;
 799     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 800
 801     return
 802         unless defined $callers_bitmask &&
 803                 (vec($callers_bitmask, $offset, 1) ||
 804                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 805
 806     require Carp;
 807     Carp::croak($message)
 808         if vec($callers_bitmask, $offset+1, 1) ||
 809            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 810
 811     Carp::carp($message) ;
 812 }
 813
 814 1;