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.13';
 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 and the list of built-in warning
 473 categories.
 474
 475 If no import list is supplied, all possible warnings are either enabled
 476 or disabled.
 477
 478 A number of functions are provided to assist module authors.
 479
 480 =over 4
 481
 482 =item use warnings::register
 483
 484 Creates a new warnings category with the same name as the package where
 485 the call to the pragma is used.
 486
 487 =item warnings::enabled()
 488
 489 Use the warnings category with the same name as the current package.
 490
 491 Return TRUE if that warnings category is enabled in the calling module.
 492 Otherwise returns FALSE.
 493
 494 =item warnings::enabled($category)
 495
 496 Return TRUE if the warnings category, C<$category>, is enabled in the
 497 calling module.
 498 Otherwise returns FALSE.
 499
 500 =item warnings::enabled($object)
 501
 502 Use the name of the class for the object reference, C<$object>, as the
 503 warnings category.
 504
 505 Return TRUE if that warnings category is enabled in the first scope
 506 where the object is used.
 507 Otherwise returns FALSE.
 508
 509 =item warnings::fatal_enabled()
 510
 511 Return TRUE if the warnings category with the same name as the current
 512 package has been set to FATAL in the calling module.
 513 Otherwise returns FALSE.
 514
 515 =item warnings::fatal_enabled($category)
 516
 517 Return TRUE if the warnings category C<$category> has been set to FATAL in
 518 the calling module.
 519 Otherwise returns FALSE.
 520
 521 =item warnings::fatal_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 has been set to FATAL in the first
 527 scope 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 =item warnings::register_categories(@names)
 579
 580 This registers warning categories for the given names and is primarily for
 581 use by the warnings::register pragma, for which see L<perllexwarn>.
 582
 583 =back
 584
 585 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 586
 587 =cut
 588
 589 KEYWORDS
 590
 591 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 592
 593 sub Croaker
 594 {
 595     require Carp; # this initializes %CarpInternal
 596     local $Carp::CarpInternal{'warnings'};
 597     delete $Carp::CarpInternal{'warnings'};
 598     Carp::croak(@_);
 599 }
 600
 601 sub _bits {
 602     my $mask = shift ;
 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 bits
 629 {
 630     # called from B::Deparse.pm
 631     push @_, 'all' unless @_ ;
 632     return _bits(undef, @_) ;
 633 }
 634
 635 sub import
 636 {
 637     shift;
 638
 639     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
 640
 641     if (vec($mask, $Offsets{'all'}, 1)) {
 642         $mask |= $Bits{'all'} ;
 643         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 644     }
 645
 646     # Empty @_ is equivalent to @_ = 'all' ;
 647     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
 648 }
 649
 650 sub unimport
 651 {
 652     shift;
 653
 654     my $catmask ;
 655     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
 656
 657     if (vec($mask, $Offsets{'all'}, 1)) {
 658         $mask |= $Bits{'all'} ;
 659         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 660     }
 661
 662     push @_, 'all' unless @_;
 663
 664     foreach my $word ( @_ ) {
 665         if ($word eq 'FATAL') {
 666             next;
 667         }
 668         elsif ($catmask = $Bits{$word}) {
 669             $mask &= ~($catmask | $DeadBits{$word} | $All);
 670         }
 671         else
 672           { Croaker("Unknown warnings category '$word'")}
 673     }
 674
 675     ${^WARNING_BITS} = $mask ;
 676 }
 677
 678 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 679
 680 sub MESSAGE () { 4 };
 681 sub FATAL () { 2 };
 682 sub NORMAL () { 1 };
 683
 684 sub __chk
 685 {
 686     my $category ;
 687     my $offset ;
 688     my $isobj = 0 ;
 689     my $wanted = shift;
 690     my $has_message = $wanted & MESSAGE;
 691
 692     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
 693         my $sub = (caller 1)[3];
 694         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
 695         Croaker("Usage: $sub($syntax)");
 696     }
 697
 698     my $message = pop if $has_message;
 699
 700     if (@_) {
 701         # check the category supplied.
 702         $category = shift ;
 703         if (my $type = ref $category) {
 704             Croaker("not an object")
 705                 if exists $builtin_type{$type};
 706             $category = $type;
 707             $isobj = 1 ;
 708         }
 709         $offset = $Offsets{$category};
 710         Croaker("Unknown warnings category '$category'")
 711             unless defined $offset;
 712     }
 713     else {
 714         $category = (caller(1))[0] ;
 715         $offset = $Offsets{$category};
 716         Croaker("package '$category' not registered for warnings")
 717             unless defined $offset ;
 718     }
 719
 720     my $i;
 721
 722     if ($isobj) {
 723         my $pkg;
 724         $i = 2;
 725         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 726             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 727         }
 728         $i -= 2 ;
 729     }
 730     else {
 731         $i = _error_loc(); # see where Carp will allocate the error
 732     }
 733
 734     # Defaulting this to 0 reduces complexity in code paths below.
 735     my $callers_bitmask = (caller($i))[9] || 0 ;
 736
 737     my @results;
 738     foreach my $type (FATAL, NORMAL) {
 739         next unless $wanted & $type;
 740
 741         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
 742                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
 743     }
 744
 745     # &enabled and &fatal_enabled
 746     return $results[0] unless $has_message;
 747
 748     # &warnif, and the category is neither enabled as warning nor as fatal
 749     return if $wanted == (NORMAL | FATAL | MESSAGE)
 750         && !($results[0] || $results[1]);
 751
 752     require Carp;
 753     Carp::croak($message) if $results[0];
 754     # will always get here for &warn. will only get here for &warnif if the
 755     # category is enabled
 756     Carp::carp($message);
 757 }
 758
 759 sub _mkMask
 760 {
 761     my ($bit) = @_;
 762     my $mask = "";
 763
 764     vec($mask, $bit, 1) = 1;
 765     return $mask;
 766 }
 767
 768 sub register_categories
 769 {
 770     my @names = @_;
 771
 772     for my $name (@names) {
 773         if (! defined $Bits{$name}) {
 774             $Bits{$name}     = _mkMask($LAST_BIT);
 775             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
 776             $Offsets{$name}  = $LAST_BIT ++;
 777             foreach my $k (keys %Bits) {
 778                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
 779             }
 780             $DeadBits{$name} = _mkMask($LAST_BIT);
 781             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
 782         }
 783     }
 784 }
 785
 786 sub _error_loc {
 787     require Carp;
 788     goto &Carp::short_error_loc; # don't introduce another stack frame
 789 }
 790
 791 sub enabled
 792 {
 793     return __chk(NORMAL, @_);
 794 }
 795
 796 sub fatal_enabled
 797 {
 798     return __chk(FATAL, @_);
 799 }
 800
 801 sub warn
 802 {
 803     return __chk(FATAL | MESSAGE, @_);
 804 }
 805
 806 sub warnif
 807 {
 808     return __chk(NORMAL | FATAL | MESSAGE, @_);
 809 }
 810
 811 # These are not part of any public interface, so we can delete them to save
 812 # space.
 813 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
 814
 815 1;