1# -*- buffer-read-only: t -*- 2# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! 3# This file is built by regen/warnings.pl. 4# Any changes made here will be lost! 5 6package warnings; 7 8our $VERSION = '1.23'; 9 10# Verify that we're called correctly so that warnings will work. 11# see also strict.pm. 12unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) { 13 my (undef, $f, $l) = caller; 14 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n"); 15} 16 17=head1 NAME 18 19warnings - Perl pragma to control optional warnings 20 21=head1 SYNOPSIS 22 23 use warnings; 24 no warnings; 25 26 use warnings "all"; 27 no warnings "all"; 28 29 use warnings::register; 30 if (warnings::enabled()) { 31 warnings::warn("some warning"); 32 } 33 34 if (warnings::enabled("void")) { 35 warnings::warn("void", "some warning"); 36 } 37 38 if (warnings::enabled($object)) { 39 warnings::warn($object, "some warning"); 40 } 41 42 warnings::warnif("some warning"); 43 warnings::warnif("void", "some warning"); 44 warnings::warnif($object, "some warning"); 45 46=head1 DESCRIPTION 47 48The C<warnings> pragma gives control over which warnings are enabled in 49which parts of a Perl program. It's a more flexible alternative for 50both the command line flag B<-w> and the equivalent Perl variable, 51C<$^W>. 52 53This pragma works just like the C<strict> pragma. 54This means that the scope of the warning pragma is limited to the 55enclosing block. It also means that the pragma setting will not 56leak across files (via C<use>, C<require> or C<do>). This allows 57authors to independently define the degree of warning checks that will 58be applied to their module. 59 60By default, optional warnings are disabled, so any legacy code that 61doesn't attempt to control the warnings will work unchanged. 62 63All warnings are enabled in a block by either of these: 64 65 use warnings; 66 use warnings 'all'; 67 68Similarly all warnings are disabled in a block by either of these: 69 70 no warnings; 71 no warnings 'all'; 72 73For example, consider the code below: 74 75 use warnings; 76 my @a; 77 { 78 no warnings; 79 my $b = @a[0]; 80 } 81 my $c = @a[0]; 82 83The code in the enclosing block has warnings enabled, but the inner 84block has them disabled. In this case that means the assignment to the 85scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]"> 86warning, but the assignment to the scalar C<$b> will not. 87 88=head2 Default Warnings and Optional Warnings 89 90Before the introduction of lexical warnings, Perl had two classes of 91warnings: mandatory and optional. 92 93As its name suggests, if your code tripped a mandatory warning, you 94would get a warning whether you wanted it or not. 95For example, the code below would always produce an C<"isn't numeric"> 96warning about the "2:". 97 98 my $a = "2:" + 3; 99 100With the introduction of lexical warnings, mandatory warnings now become 101I<default> warnings. The difference is that although the previously 102mandatory warnings are still enabled by default, they can then be 103subsequently enabled or disabled with the lexical warning pragma. For 104example, in the code below, an C<"isn't numeric"> warning will only 105be reported for the C<$a> variable. 106 107 my $a = "2:" + 3; 108 no warnings; 109 my $b = "2:" + 3; 110 111Note that neither the B<-w> flag or the C<$^W> can be used to 112disable/enable default warnings. They are still mandatory in this case. 113 114=head2 What's wrong with B<-w> and C<$^W> 115 116Although very useful, the big problem with using B<-w> on the command 117line to enable warnings is that it is all or nothing. Take the typical 118scenario when you are writing a Perl program. Parts of the code you 119will write yourself, but it's very likely that you will make use of 120pre-written Perl modules. If you use the B<-w> flag in this case, you 121end up enabling warnings in pieces of code that you haven't written. 122 123Similarly, using C<$^W> to either disable or enable blocks of code is 124fundamentally flawed. For a start, say you want to disable warnings in 125a block of code. You might expect this to be enough to do the trick: 126 127 { 128 local ($^W) = 0; 129 my $a =+ 2; 130 my $b; chop $b; 131 } 132 133When this code is run with the B<-w> flag, a warning will be produced 134for the C<$a> line: C<"Reversed += operator">. 135 136The problem is that Perl has both compile-time and run-time warnings. To 137disable compile-time warnings you need to rewrite the code like this: 138 139 { 140 BEGIN { $^W = 0 } 141 my $a =+ 2; 142 my $b; chop $b; 143 } 144 145The other big problem with C<$^W> is the way you can inadvertently 146change the warning setting in unexpected places in your code. For example, 147when the code below is run (without the B<-w> flag), the second call 148to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas 149the first will not. 150 151 sub doit 152 { 153 my $b; chop $b; 154 } 155 156 doit(); 157 158 { 159 local ($^W) = 1; 160 doit() 161 } 162 163This is a side-effect of C<$^W> being dynamically scoped. 164 165Lexical warnings get around these limitations by allowing finer control 166over where warnings can or can't be tripped. 167 168=head2 Controlling Warnings from the Command Line 169 170There are three Command Line flags that can be used to control when 171warnings are (or aren't) produced: 172 173=over 5 174 175=item B<-w> 176X<-w> 177 178This is the existing flag. If the lexical warnings pragma is B<not> 179used in any of you code, or any of the modules that you use, this flag 180will enable warnings everywhere. See L<Backward Compatibility> for 181details of how this flag interacts with lexical warnings. 182 183=item B<-W> 184X<-W> 185 186If the B<-W> flag is used on the command line, it will enable all warnings 187throughout the program regardless of whether warnings were disabled 188locally using C<no warnings> or C<$^W =0>. 189This includes all files that get 190included via C<use>, C<require> or C<do>. 191Think of it as the Perl equivalent of the "lint" command. 192 193=item B<-X> 194X<-X> 195 196Does the exact opposite to the B<-W> flag, i.e. it disables all warnings. 197 198=back 199 200=head2 Backward Compatibility 201 202If you are used to working with a version of Perl prior to the 203introduction of lexically scoped warnings, or have code that uses both 204lexical warnings and C<$^W>, this section will describe how they interact. 205 206How Lexical Warnings interact with B<-w>/C<$^W>: 207 208=over 5 209 210=item 1. 211 212If none of the three command line flags (B<-w>, B<-W> or B<-X>) that 213control warnings is used and neither C<$^W> nor the C<warnings> pragma 214are used, then default warnings will be enabled and optional warnings 215disabled. 216This means that legacy code that doesn't attempt to control the warnings 217will work unchanged. 218 219=item 2. 220 221The B<-w> flag just sets the global C<$^W> variable as in 5.005. This 222means that any legacy code that currently relies on manipulating C<$^W> 223to control warning behavior will still work as is. 224 225=item 3. 226 227Apart from now being a boolean, the C<$^W> variable operates in exactly 228the same horrible uncontrolled global way, except that it cannot 229disable/enable default warnings. 230 231=item 4. 232 233If a piece of code is under the control of the C<warnings> pragma, 234both the C<$^W> variable and the B<-w> flag will be ignored for the 235scope of the lexical warning. 236 237=item 5. 238 239The only way to override a lexical warnings setting is with the B<-W> 240or B<-X> command line flags. 241 242=back 243 244The combined effect of 3 & 4 is that it will allow code which uses 245the C<warnings> pragma to control the warning behavior of $^W-type 246code (using a C<local $^W=0>) if it really wants to, but not vice-versa. 247 248=head2 Category Hierarchy 249X<warning, categories> 250 251A hierarchy of "categories" have been defined to allow groups of warnings 252to be enabled/disabled in isolation. 253 254The current hierarchy is: 255 256 all -+ 257 | 258 +- closure 259 | 260 +- deprecated 261 | 262 +- exiting 263 | 264 +- experimental --+ 265 | | 266 | +- experimental::autoderef 267 | | 268 | +- experimental::lexical_subs 269 | | 270 | +- experimental::lexical_topic 271 | | 272 | +- experimental::postderef 273 | | 274 | +- experimental::regex_sets 275 | | 276 | +- experimental::signatures 277 | | 278 | +- experimental::smartmatch 279 | 280 +- glob 281 | 282 +- imprecision 283 | 284 +- io ------------+ 285 | | 286 | +- closed 287 | | 288 | +- exec 289 | | 290 | +- layer 291 | | 292 | +- newline 293 | | 294 | +- pipe 295 | | 296 | +- syscalls 297 | | 298 | +- unopened 299 | 300 +- misc 301 | 302 +- numeric 303 | 304 +- once 305 | 306 +- overflow 307 | 308 +- pack 309 | 310 +- portable 311 | 312 +- recursion 313 | 314 +- redefine 315 | 316 +- regexp 317 | 318 +- severe --------+ 319 | | 320 | +- debugging 321 | | 322 | +- inplace 323 | | 324 | +- internal 325 | | 326 | +- malloc 327 | 328 +- signal 329 | 330 +- substr 331 | 332 +- syntax --------+ 333 | | 334 | +- ambiguous 335 | | 336 | +- bareword 337 | | 338 | +- digit 339 | | 340 | +- illegalproto 341 | | 342 | +- parenthesis 343 | | 344 | +- precedence 345 | | 346 | +- printf 347 | | 348 | +- prototype 349 | | 350 | +- qw 351 | | 352 | +- reserved 353 | | 354 | +- semicolon 355 | 356 +- taint 357 | 358 +- threads 359 | 360 +- uninitialized 361 | 362 +- unpack 363 | 364 +- untie 365 | 366 +- utf8 ----------+ 367 | | 368 | +- non_unicode 369 | | 370 | +- nonchar 371 | | 372 | +- surrogate 373 | 374 +- void 375 376Just like the "strict" pragma any of these categories can be combined 377 378 use warnings qw(void redefine); 379 no warnings qw(io syntax untie); 380 381Also like the "strict" pragma, if there is more than one instance of the 382C<warnings> pragma in a given scope the cumulative effect is additive. 383 384 use warnings qw(void); # only "void" warnings enabled 385 ... 386 use warnings qw(io); # only "void" & "io" warnings enabled 387 ... 388 no warnings qw(void); # only "io" warnings enabled 389 390To determine which category a specific warning has been assigned to see 391L<perldiag>. 392 393Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a 394sub-category of the "syntax" category. It is now a top-level category 395in its own right. 396 397=head2 Fatal Warnings 398X<warning, fatal> 399 400The presence of the word "FATAL" in the category list will escalate any 401warnings detected from the categories specified in the lexical scope 402into fatal errors. In the code below, the use of C<time>, C<length> 403and C<join> can all produce a C<"Useless use of xxx in void context"> 404warning. 405 406 use warnings; 407 408 time; 409 410 { 411 use warnings FATAL => qw(void); 412 length "abc"; 413 } 414 415 join "", 1,2,3; 416 417 print "done\n"; 418 419When run it produces this output 420 421 Useless use of time in void context at fatal line 3. 422 Useless use of length in void context at fatal line 7. 423 424The scope where C<length> is used has escalated the C<void> warnings 425category into a fatal error, so the program terminates immediately when it 426encounters the warning. 427 428To explicitly turn off a "FATAL" warning you just disable the warning 429it is associated with. So, for example, to disable the "void" warning 430in the example above, either of these will do the trick: 431 432 no warnings qw(void); 433 no warnings FATAL => qw(void); 434 435If you want to downgrade a warning that has been escalated into a fatal 436error back to a normal warning, you can use the "NONFATAL" keyword. For 437example, the code below will promote all warnings into fatal errors, 438except for those in the "syntax" category. 439 440 use warnings FATAL => 'all', NONFATAL => 'syntax'; 441 442As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can 443use: 444 445 use v5.20; # Perl 5.20 or greater is required for the following 446 use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';" 447 448If you want your program to be compatible with versions of Perl before 4495.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In 450previous versions of Perl, the behavior of the statements 451C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and 452C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if 453they included the C<< => 'all' >> portion. As of 5.20, they do.) 454 455B<NOTE:> Users of FATAL warnings, especially 456those using C<< FATAL => 'all' >> 457should be fully aware that they are risking future portability of their 458programs by doing so. Perl makes absolutely no commitments to not 459introduce new warnings, or warnings categories in the future, and indeed 460we explicitly reserve the right to do so. Code that may not warn now may 461warn in a future release of Perl if the Perl5 development team deems it 462in the best interests of the community to do so. Should code using FATAL 463warnings break due to the introduction of a new warning we will NOT 464consider it an incompatible change. Users of FATAL warnings should take 465special caution during upgrades to check to see if their code triggers 466any new warnings and should pay particular attention to the fine print of 467the documentation of the features they use to ensure they do not exploit 468features that are documented as risky, deprecated, or unspecified, or where 469the documentation says "so don't do that", or anything with the same sense 470and spirit. Use of such features in combination with FATAL warnings is 471ENTIRELY AT THE USER'S RISK. 472 473=head2 Reporting Warnings from a Module 474X<warning, reporting> X<warning, registering> 475 476The C<warnings> pragma provides a number of functions that are useful for 477module authors. These are used when you want to report a module-specific 478warning to a calling module has enabled warnings via the C<warnings> 479pragma. 480 481Consider the module C<MyMod::Abc> below. 482 483 package MyMod::Abc; 484 485 use warnings::register; 486 487 sub open { 488 my $path = shift; 489 if ($path !~ m#^/#) { 490 warnings::warn("changing relative path to /var/abc") 491 if warnings::enabled(); 492 $path = "/var/abc/$path"; 493 } 494 } 495 496 1; 497 498The call to C<warnings::register> will create a new warnings category 499called "MyMod::Abc", i.e. the new category name matches the current 500package name. The C<open> function in the module will display a warning 501message if it gets given a relative path as a parameter. This warnings 502will only be displayed if the code that uses C<MyMod::Abc> has actually 503enabled them with the C<warnings> pragma like below. 504 505 use MyMod::Abc; 506 use warnings 'MyMod::Abc'; 507 ... 508 abc::open("../fred.txt"); 509 510It is also possible to test whether the pre-defined warnings categories are 511set in the calling module with the C<warnings::enabled> function. Consider 512this snippet of code: 513 514 package MyMod::Abc; 515 516 sub open { 517 warnings::warnif("deprecated", 518 "open is deprecated, use new instead"); 519 new(@_); 520 } 521 522 sub new 523 ... 524 1; 525 526The function C<open> has been deprecated, so code has been included to 527display a warning message whenever the calling module has (at least) the 528"deprecated" warnings category enabled. Something like this, say. 529 530 use warnings 'deprecated'; 531 use MyMod::Abc; 532 ... 533 MyMod::Abc::open($filename); 534 535Either the C<warnings::warn> or C<warnings::warnif> function should be 536used to actually display the warnings message. This is because they can 537make use of the feature that allows warnings to be escalated into fatal 538errors. So in this case 539 540 use MyMod::Abc; 541 use warnings FATAL => 'MyMod::Abc'; 542 ... 543 MyMod::Abc::open('../fred.txt'); 544 545the C<warnings::warnif> function will detect this and die after 546displaying the warning message. 547 548The three warnings functions, C<warnings::warn>, C<warnings::warnif> 549and C<warnings::enabled> can optionally take an object reference in place 550of a category name. In this case the functions will use the class name 551of the object as the warnings category. 552 553Consider this example: 554 555 package Original; 556 557 no warnings; 558 use warnings::register; 559 560 sub new 561 { 562 my $class = shift; 563 bless [], $class; 564 } 565 566 sub check 567 { 568 my $self = shift; 569 my $value = shift; 570 571 if ($value % 2 && warnings::enabled($self)) 572 { warnings::warn($self, "Odd numbers are unsafe") } 573 } 574 575 sub doit 576 { 577 my $self = shift; 578 my $value = shift; 579 $self->check($value); 580 # ... 581 } 582 583 1; 584 585 package Derived; 586 587 use warnings::register; 588 use Original; 589 our @ISA = qw( Original ); 590 sub new 591 { 592 my $class = shift; 593 bless [], $class; 594 } 595 596 597 1; 598 599The code below makes use of both modules, but it only enables warnings from 600C<Derived>. 601 602 use Original; 603 use Derived; 604 use warnings 'Derived'; 605 my $a = Original->new(); 606 $a->doit(1); 607 my $b = Derived->new(); 608 $a->doit(1); 609 610When this code is run only the C<Derived> object, C<$b>, will generate 611a warning. 612 613 Odd numbers are unsafe at main.pl line 7 614 615Notice also that the warning is reported at the line where the object is first 616used. 617 618When registering new categories of warning, you can supply more names to 619warnings::register like this: 620 621 package MyModule; 622 use warnings::register qw(format precision); 623 624 ... 625 626 warnings::warnif('MyModule::format', '...'); 627 628=head1 FUNCTIONS 629 630=over 4 631 632=item use warnings::register 633 634Creates a new warnings category with the same name as the package where 635the call to the pragma is used. 636 637=item warnings::enabled() 638 639Use the warnings category with the same name as the current package. 640 641Return TRUE if that warnings category is enabled in the calling module. 642Otherwise returns FALSE. 643 644=item warnings::enabled($category) 645 646Return TRUE if the warnings category, C<$category>, is enabled in the 647calling module. 648Otherwise returns FALSE. 649 650=item warnings::enabled($object) 651 652Use the name of the class for the object reference, C<$object>, as the 653warnings category. 654 655Return TRUE if that warnings category is enabled in the first scope 656where the object is used. 657Otherwise returns FALSE. 658 659=item warnings::fatal_enabled() 660 661Return TRUE if the warnings category with the same name as the current 662package has been set to FATAL in the calling module. 663Otherwise returns FALSE. 664 665=item warnings::fatal_enabled($category) 666 667Return TRUE if the warnings category C<$category> has been set to FATAL in 668the calling module. 669Otherwise returns FALSE. 670 671=item warnings::fatal_enabled($object) 672 673Use the name of the class for the object reference, C<$object>, as the 674warnings category. 675 676Return TRUE if that warnings category has been set to FATAL in the first 677scope where the object is used. 678Otherwise returns FALSE. 679 680=item warnings::warn($message) 681 682Print C<$message> to STDERR. 683 684Use the warnings category with the same name as the current package. 685 686If that warnings category has been set to "FATAL" in the calling module 687then die. Otherwise return. 688 689=item warnings::warn($category, $message) 690 691Print C<$message> to STDERR. 692 693If the warnings category, C<$category>, has been set to "FATAL" in the 694calling module then die. Otherwise return. 695 696=item warnings::warn($object, $message) 697 698Print C<$message> to STDERR. 699 700Use the name of the class for the object reference, C<$object>, as the 701warnings category. 702 703If that warnings category has been set to "FATAL" in the scope where C<$object> 704is first used then die. Otherwise return. 705 706 707=item warnings::warnif($message) 708 709Equivalent to: 710 711 if (warnings::enabled()) 712 { warnings::warn($message) } 713 714=item warnings::warnif($category, $message) 715 716Equivalent to: 717 718 if (warnings::enabled($category)) 719 { warnings::warn($category, $message) } 720 721=item warnings::warnif($object, $message) 722 723Equivalent to: 724 725 if (warnings::enabled($object)) 726 { warnings::warn($object, $message) } 727 728=item warnings::register_categories(@names) 729 730This registers warning categories for the given names and is primarily for 731use by the warnings::register pragma. 732 733=back 734 735See also L<perlmodlib/Pragmatic Modules> and L<perldiag>. 736 737=cut 738 739our %Offsets = ( 740 741 # Warnings Categories added in Perl 5.008 742 743 'all' => 0, 744 'closure' => 2, 745 'deprecated' => 4, 746 'exiting' => 6, 747 'glob' => 8, 748 'io' => 10, 749 'closed' => 12, 750 'exec' => 14, 751 'layer' => 16, 752 'newline' => 18, 753 'pipe' => 20, 754 'unopened' => 22, 755 'misc' => 24, 756 'numeric' => 26, 757 'once' => 28, 758 'overflow' => 30, 759 'pack' => 32, 760 'portable' => 34, 761 'recursion' => 36, 762 'redefine' => 38, 763 'regexp' => 40, 764 'severe' => 42, 765 'debugging' => 44, 766 'inplace' => 46, 767 'internal' => 48, 768 'malloc' => 50, 769 'signal' => 52, 770 'substr' => 54, 771 'syntax' => 56, 772 'ambiguous' => 58, 773 'bareword' => 60, 774 'digit' => 62, 775 'parenthesis' => 64, 776 'precedence' => 66, 777 'printf' => 68, 778 'prototype' => 70, 779 'qw' => 72, 780 'reserved' => 74, 781 'semicolon' => 76, 782 'taint' => 78, 783 'threads' => 80, 784 'uninitialized' => 82, 785 'unpack' => 84, 786 'untie' => 86, 787 'utf8' => 88, 788 'void' => 90, 789 790 # Warnings Categories added in Perl 5.011 791 792 'imprecision' => 92, 793 'illegalproto' => 94, 794 795 # Warnings Categories added in Perl 5.013 796 797 'non_unicode' => 96, 798 'nonchar' => 98, 799 'surrogate' => 100, 800 801 # Warnings Categories added in Perl 5.017 802 803 'experimental' => 102, 804 'experimental::lexical_subs'=> 104, 805 'experimental::lexical_topic'=> 106, 806 'experimental::regex_sets'=> 108, 807 'experimental::smartmatch'=> 110, 808 809 # Warnings Categories added in Perl 5.019 810 811 'experimental::autoderef'=> 112, 812 'experimental::postderef'=> 114, 813 'experimental::signatures'=> 116, 814 'syscalls' => 118, 815 ); 816 817our %Bits = ( 818 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..59] 819 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [29] 820 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [30] 821 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] 822 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] 823 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] 824 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] 825 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [31] 826 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 827 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] 828 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x15", # [51..58] 829 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [56] 830 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [52] 831 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [53] 832 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [57] 833 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [54] 834 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [58] 835 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [55] 836 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] 837 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [47] 838 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [46] 839 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] 840 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [24] 841 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [5..11,59] 842 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] 843 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [25] 844 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] 845 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] 846 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [48] 847 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [49] 848 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13] 849 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14] 850 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15] 851 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16] 852 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [32] 853 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] 854 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17] 855 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [33] 856 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [34] 857 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [35] 858 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [36] 859 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] 860 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] 861 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] 862 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [37] 863 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [38] 864 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25] 865 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [26] 866 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [27] 867 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [50] 868 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00", # [28..38,47] 869 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [59] 870 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [39] 871 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [40] 872 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [41] 873 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] 874 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [42] 875 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [43] 876 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00", # [44,48..50] 877 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [45] 878 ); 879 880our %DeadBits = ( 881 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..59] 882 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [29] 883 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [30] 884 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] 885 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] 886 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] 887 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] 888 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [31] 889 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 890 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] 891 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x2a", # [51..58] 892 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [56] 893 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [52] 894 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [53] 895 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [57] 896 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [54] 897 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [58] 898 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [55] 899 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] 900 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [47] 901 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [46] 902 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] 903 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [24] 904 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [5..11,59] 905 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] 906 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [25] 907 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] 908 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] 909 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [48] 910 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [49] 911 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13] 912 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14] 913 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15] 914 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16] 915 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [32] 916 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] 917 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17] 918 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [33] 919 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [34] 920 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [35] 921 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [36] 922 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] 923 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] 924 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] 925 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [37] 926 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [38] 927 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25] 928 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [26] 929 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [27] 930 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [50] 931 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00", # [28..38,47] 932 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [59] 933 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [39] 934 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [40] 935 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [41] 936 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] 937 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [42] 938 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [43] 939 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00", # [44,48..50] 940 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [45] 941 ); 942 943$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; 944$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15", # [2,56,52,53,57,54,58,55,4,22,23,25] 945$LAST_BIT = 120 ; 946$BYTES = 15 ; 947 948$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; 949 950sub Croaker 951{ 952 require Carp; # this initializes %CarpInternal 953 local $Carp::CarpInternal{'warnings'}; 954 delete $Carp::CarpInternal{'warnings'}; 955 Carp::croak(@_); 956} 957 958sub _bits { 959 my $mask = shift ; 960 my $catmask ; 961 my $fatal = 0 ; 962 my $no_fatal = 0 ; 963 964 foreach my $word ( @_ ) { 965 if ($word eq 'FATAL') { 966 $fatal = 1; 967 $no_fatal = 0; 968 } 969 elsif ($word eq 'NONFATAL') { 970 $fatal = 0; 971 $no_fatal = 1; 972 } 973 elsif ($catmask = $Bits{$word}) { 974 $mask |= $catmask ; 975 $mask |= $DeadBits{$word} if $fatal ; 976 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; 977 } 978 else 979 { Croaker("Unknown warnings category '$word'")} 980 } 981 982 return $mask ; 983} 984 985sub bits 986{ 987 # called from B::Deparse.pm 988 push @_, 'all' unless @_ ; 989 return _bits(undef, @_) ; 990} 991 992sub import 993{ 994 shift; 995 996 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; 997 998 if (vec($mask, $Offsets{'all'}, 1)) { 999 $mask |= $Bits{'all'} ; 1000 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); 1001 } 1002 1003 # append 'all' when implied (after a lone "FATAL" or "NONFATAL") 1004 push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' ); 1005 1006 # Empty @_ is equivalent to @_ = 'all' ; 1007 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ; 1008} 1009 1010sub unimport 1011{ 1012 shift; 1013 1014 my $catmask ; 1015 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; 1016 1017 if (vec($mask, $Offsets{'all'}, 1)) { 1018 $mask |= $Bits{'all'} ; 1019 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); 1020 } 1021 1022 # append 'all' when implied (empty import list or after a lone "FATAL") 1023 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL'; 1024 1025 foreach my $word ( @_ ) { 1026 if ($word eq 'FATAL') { 1027 next; 1028 } 1029 elsif ($catmask = $Bits{$word}) { 1030 $mask &= ~($catmask | $DeadBits{$word} | $All); 1031 } 1032 else 1033 { Croaker("Unknown warnings category '$word'")} 1034 } 1035 1036 ${^WARNING_BITS} = $mask ; 1037} 1038 1039my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); 1040 1041sub MESSAGE () { 4 }; 1042sub FATAL () { 2 }; 1043sub NORMAL () { 1 }; 1044 1045sub __chk 1046{ 1047 my $category ; 1048 my $offset ; 1049 my $isobj = 0 ; 1050 my $wanted = shift; 1051 my $has_message = $wanted & MESSAGE; 1052 1053 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) { 1054 my $sub = (caller 1)[3]; 1055 my $syntax = $has_message ? "[category,] 'message'" : '[category]'; 1056 Croaker("Usage: $sub($syntax)"); 1057 } 1058 1059 my $message = pop if $has_message; 1060 1061 if (@_) { 1062 # check the category supplied. 1063 $category = shift ; 1064 if (my $type = ref $category) { 1065 Croaker("not an object") 1066 if exists $builtin_type{$type}; 1067 $category = $type; 1068 $isobj = 1 ; 1069 } 1070 $offset = $Offsets{$category}; 1071 Croaker("Unknown warnings category '$category'") 1072 unless defined $offset; 1073 } 1074 else { 1075 $category = (caller(1))[0] ; 1076 $offset = $Offsets{$category}; 1077 Croaker("package '$category' not registered for warnings") 1078 unless defined $offset ; 1079 } 1080 1081 my $i; 1082 1083 if ($isobj) { 1084 my $pkg; 1085 $i = 2; 1086 while (do { { package DB; $pkg = (caller($i++))[0] } } ) { 1087 last unless @DB::args && $DB::args[0] =~ /^$category=/ ; 1088 } 1089 $i -= 2 ; 1090 } 1091 else { 1092 $i = _error_loc(); # see where Carp will allocate the error 1093 } 1094 1095 # Default to 0 if caller returns nothing. Default to $DEFAULT if it 1096 # explicitly returns undef. 1097 my(@callers_bitmask) = (caller($i))[9] ; 1098 my $callers_bitmask = 1099 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ; 1100 1101 my @results; 1102 foreach my $type (FATAL, NORMAL) { 1103 next unless $wanted & $type; 1104 1105 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) || 1106 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1)); 1107 } 1108 1109 # &enabled and &fatal_enabled 1110 return $results[0] unless $has_message; 1111 1112 # &warnif, and the category is neither enabled as warning nor as fatal 1113 return if $wanted == (NORMAL | FATAL | MESSAGE) 1114 && !($results[0] || $results[1]); 1115 1116 require Carp; 1117 Carp::croak($message) if $results[0]; 1118 # will always get here for &warn. will only get here for &warnif if the 1119 # category is enabled 1120 Carp::carp($message); 1121} 1122 1123sub _mkMask 1124{ 1125 my ($bit) = @_; 1126 my $mask = ""; 1127 1128 vec($mask, $bit, 1) = 1; 1129 return $mask; 1130} 1131 1132sub register_categories 1133{ 1134 my @names = @_; 1135 1136 for my $name (@names) { 1137 if (! defined $Bits{$name}) { 1138 $Bits{$name} = _mkMask($LAST_BIT); 1139 vec($Bits{'all'}, $LAST_BIT, 1) = 1; 1140 $Offsets{$name} = $LAST_BIT ++; 1141 foreach my $k (keys %Bits) { 1142 vec($Bits{$k}, $LAST_BIT, 1) = 0; 1143 } 1144 $DeadBits{$name} = _mkMask($LAST_BIT); 1145 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1; 1146 } 1147 } 1148} 1149 1150sub _error_loc { 1151 require Carp; 1152 goto &Carp::short_error_loc; # don't introduce another stack frame 1153} 1154 1155sub enabled 1156{ 1157 return __chk(NORMAL, @_); 1158} 1159 1160sub fatal_enabled 1161{ 1162 return __chk(FATAL, @_); 1163} 1164 1165sub warn 1166{ 1167 return __chk(FATAL | MESSAGE, @_); 1168} 1169 1170sub warnif 1171{ 1172 return __chk(NORMAL | FATAL | MESSAGE, @_); 1173} 1174 1175# These are not part of any public interface, so we can delete them to save 1176# space. 1177delete @warnings::{qw(NORMAL FATAL MESSAGE)}; 1178 11791; 1180 1181# ex: set ro: 1182