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