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