warnings.pl

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