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