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