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