regen/warnings.pl

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