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.54'; 20 21BEGIN { 22 require './regen/regen_lib.pl'; 23 push @INC, './lib'; 24} 25use strict ; 26 27sub DEFAULT_ON () { 1 } 28sub DEFAULT_OFF () { 2 } 29 30my $tree = { 31'all' => [ 5.008, { 32 'io' => [ 5.008, { 33 'pipe' => [ 5.008, DEFAULT_OFF], 34 'unopened' => [ 5.008, DEFAULT_OFF], 35 'closed' => [ 5.008, DEFAULT_OFF], 36 'newline' => [ 5.008, DEFAULT_OFF], 37 'exec' => [ 5.008, DEFAULT_OFF], 38 'layer' => [ 5.008, DEFAULT_OFF], 39 'syscalls' => [ 5.019, 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::smartmatch' => 93 [ 5.017, DEFAULT_ON ], 94 'experimental::postderef' => 95 [ 5.019, DEFAULT_ON ], 96 'experimental::signatures' => 97 [ 5.019, DEFAULT_ON ], 98 'experimental::refaliasing' => 99 [ 5.021, DEFAULT_ON ], 100 'experimental::re_strict' => 101 [ 5.021, DEFAULT_ON ], 102 'experimental::const_attr' => 103 [ 5.021, DEFAULT_ON ], 104 'experimental::bitwise' => 105 [ 5.021, DEFAULT_ON ], 106 'experimental::declared_refs' => 107 [ 5.025, DEFAULT_ON ], 108 'experimental::script_run' => 109 [ 5.027, DEFAULT_ON ], 110 'experimental::alpha_assertions' => 111 [ 5.027, DEFAULT_ON ], 112 'experimental::private_use' => 113 [ 5.029, DEFAULT_ON ], 114 'experimental::uniprop_wildcards' => 115 [ 5.029, DEFAULT_ON ], 116 'experimental::vlb' => 117 [ 5.029, DEFAULT_ON ], 118 'experimental::isa' => 119 [ 5.031, DEFAULT_ON ], 120 'experimental::try' => 121 [ 5.033, DEFAULT_ON ], 122 'experimental::defer' => 123 [ 5.035, DEFAULT_ON ], 124 }], 125 126 'missing' => [ 5.021, DEFAULT_OFF], 127 'redundant' => [ 5.021, DEFAULT_OFF], 128 'locale' => [ 5.021, DEFAULT_ON], 129 'shadow' => [ 5.027, DEFAULT_OFF], 130 131 #'default' => [ 5.008, DEFAULT_ON ], 132}]}; 133 134my @def ; 135my %list ; 136my %Value ; 137my %ValueToName ; 138my %NameToValue ; 139 140my %v_list = () ; 141 142sub valueWalk 143{ 144 my $tre = shift ; 145 my @list = () ; 146 my ($k, $v) ; 147 148 foreach $k (sort keys %$tre) { 149 $v = $tre->{$k}; 150 die "duplicate key $k\n" if defined $list{$k} ; 151 die "Value associated with key '$k' is not an ARRAY reference" 152 if !ref $v || ref $v ne 'ARRAY' ; 153 154 my ($ver, $rest) = @{ $v } ; 155 push @{ $v_list{$ver} }, $k; 156 157 if (ref $rest) 158 { valueWalk ($rest) } 159 160 } 161 162} 163 164sub orderValues 165{ 166 my $index = 0; 167 foreach my $ver ( sort { $a <=> $b } keys %v_list ) { 168 foreach my $name (@{ $v_list{$ver} } ) { 169 $ValueToName{ $index } = [ uc $name, $ver ] ; 170 $NameToValue{ uc $name } = $index ++ ; 171 } 172 } 173 174 return $index ; 175} 176 177########################################################################### 178 179sub walk 180{ 181 my $tre = shift ; 182 my @list = () ; 183 my ($k, $v) ; 184 185 foreach $k (sort keys %$tre) { 186 $v = $tre->{$k}; 187 die "duplicate key $k\n" if defined $list{$k} ; 188 die "Can't find key '$k'" 189 if ! defined $NameToValue{uc $k} ; 190 push @{ $list{$k} }, $NameToValue{uc $k} ; 191 die "Value associated with key '$k' is not an ARRAY reference" 192 if !ref $v || ref $v ne 'ARRAY' ; 193 194 my ($ver, $rest) = @{ $v } ; 195 if (ref $rest) 196 { push (@{ $list{$k} }, walk ($rest)) } 197 elsif ($rest == DEFAULT_ON) 198 { push @def, $NameToValue{uc $k} } 199 200 push @list, @{ $list{$k} } ; 201 } 202 203 return @list ; 204} 205 206########################################################################### 207 208sub mkRange 209{ 210 my @in = @_ ; 211 my @out = @in ; 212 213 for my $i (1 .. @in - 1) { 214 $out[$i] = ".." 215 if $in[$i] == $in[$i - 1] + 1 216 && ($i >= @in - 1 || $in[$i] + 1 == $in[$i + 1] ); 217 } 218 $out[-1] = $in[-1] if $out[-1] eq ".."; 219 220 my $out = join(",",@out); 221 222 $out =~ s/,(\.\.,)+/../g ; 223 return $out; 224} 225 226########################################################################### 227sub warningsTree 228{ 229 my $tre = shift ; 230 my $prefix = shift ; 231 my ($k, $v) ; 232 233 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ; 234 my @keys = sort keys %$tre ; 235 236 my $rv = ''; 237 238 while ($k = shift @keys) { 239 $v = $tre->{$k}; 240 die "Value associated with key '$k' is not an ARRAY reference" 241 if !ref $v || ref $v ne 'ARRAY' ; 242 243 my $offset ; 244 if ($tre ne $tree) { 245 $rv .= $prefix . "|\n" ; 246 $rv .= $prefix . "+- $k" ; 247 $offset = ' ' x ($max + 4) ; 248 } 249 else { 250 $rv .= $prefix . "$k" ; 251 $offset = ' ' x ($max + 1) ; 252 } 253 254 my ($ver, $rest) = @{ $v } ; 255 if (ref $rest) 256 { 257 my $bar = @keys ? "|" : " "; 258 $rv .= " -" . "-" x ($max - length $k ) . "+\n" ; 259 $rv .= warningsTree ($rest, $prefix . $bar . $offset ) 260 } 261 else 262 { $rv .= "\n" } 263 } 264 265 return $rv; 266} 267 268########################################################################### 269 270sub mkHexOct 271{ 272 my ($f, $max, @bits) = @_ ; 273 my $mask = "\x00" x $max ; 274 my $string = "" ; 275 276 foreach (@bits) { 277 vec($mask, $_, 1) = 1 ; 278 } 279 280 foreach (unpack("C*", $mask)) { 281 if ($f eq 'x') { 282 $string .= '\x' . sprintf("%2.2x", $_) 283 } 284 else { 285 $string .= '\\' . sprintf("%o", $_) 286 } 287 } 288 return $string ; 289} 290 291sub mkHex 292{ 293 my($max, @bits) = @_; 294 return mkHexOct("x", $max, @bits); 295} 296 297sub mkOct 298{ 299 my($max, @bits) = @_; 300 return mkHexOct("o", $max, @bits); 301} 302 303########################################################################### 304 305if (@ARGV && $ARGV[0] eq "tree") 306{ 307 print warningsTree($tree, " ") ; 308 exit ; 309} 310 311my ($warn, $pm) = map { 312 open_new($_, '>', { by => 'regen/warnings.pl' }); 313} 'warnings.h', 'lib/warnings.pm'; 314 315my ($index, $warn_size); 316 317{ 318 # generate warnings.h 319 320 print $warn <<'EOM'; 321 322#define Perl_Warn_Off_(x) ((x) / 8) 323#define Perl_Warn_Bit_(x) (1 << ((x) % 8)) 324#define PerlWarnIsSet_(a, x) ((a)[Perl_Warn_Off_(x)] & Perl_Warn_Bit_(x)) 325 326 327#define G_WARN_OFF 0 /* $^W == 0 */ 328#define G_WARN_ON 1 /* -w flag and $^W != 0 */ 329#define G_WARN_ALL_ON 2 /* -W flag */ 330#define G_WARN_ALL_OFF 4 /* -X flag */ 331#define G_WARN_ONCE 8 /* set if 'once' ever enabled */ 332#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) 333 334#define pWARN_STD NULL 335#define pWARN_ALL (STRLEN *) &PL_WARN_ALL /* use warnings 'all' */ 336#define pWARN_NONE (STRLEN *) &PL_WARN_NONE /* no warnings 'all' */ 337 338#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ 339 (x) == pWARN_NONE) 340 341/* if PL_warnhook is set to this value, then warnings die */ 342#define PERL_WARNHOOK_FATAL (&PL_sv_placeholder) 343EOM 344 345 my $offset = 0 ; 346 347 valueWalk ($tree) ; 348 $index = orderValues(); 349 350 die <<EOM if $index > 255 ; 351Too many warnings categories -- max is 255 352 rewrite packWARN* & unpackWARN* macros 353EOM 354 355 walk ($tree) ; 356 for (my $i = $index; $i & 3; $i++) { 357 push @{$list{all}}, $i; 358 } 359 360 $index *= 2 ; 361 $warn_size = int($index / 8) + ($index % 8 != 0) ; 362 363 my $k ; 364 my $last_ver = 0; 365 my @names; 366 foreach $k (sort { $a <=> $b } keys %ValueToName) { 367 my ($name, $version) = @{ $ValueToName{$k} }; 368 print $warn "\n/* Warnings Categories added in Perl $version */\n\n" 369 if $last_ver != $version ; 370 $name =~ y/:/_/; 371 $name = "WARN_$name"; 372 print $warn tab(6, "#define $name"), " $k\n" ; 373 push @names, $name; 374 $last_ver = $version ; 375 } 376 377 print $warn tab(6, '#define WARNsize'), " $warn_size\n" ; 378 print $warn tab(6, '#define WARN_ALLstring'), ' "', ('\125' x $warn_size) , "\"\n" ; 379 print $warn tab(6, '#define WARN_NONEstring'), ' "', ('\0' x $warn_size) , "\"\n" ; 380 381 print $warn <<'EOM'; 382 383#define isLEXWARN_on \ 384 cBOOL(PL_curcop && PL_curcop->cop_warnings != pWARN_STD) 385#define isLEXWARN_off \ 386 cBOOL(!PL_curcop || PL_curcop->cop_warnings == pWARN_STD) 387#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) 388#define isWARN_on(c,x) (PerlWarnIsSet_((U8 *)(c + 1), 2*(x))) 389#define isWARNf_on(c,x) (PerlWarnIsSet_((U8 *)(c + 1), 2*(x)+1)) 390 391#define DUP_WARNINGS(p) Perl_dup_warnings(aTHX_ p) 392 393#define free_and_set_cop_warnings(cmp,w) STMT_START { \ 394 if (!specialWARN((cmp)->cop_warnings)) PerlMemShared_free((cmp)->cop_warnings); \ 395 (cmp)->cop_warnings = w; \ 396} STMT_END 397 398/* 399 400=head1 Warning and Dieing 401 402In all these calls, the C<U32 wI<n>> parameters are warning category 403constants. You can see the ones currently available in 404L<warnings/Category Hierarchy>, just capitalize all letters in the names 405and prefix them by C<WARN_>. So, for example, the category C<void> used in a 406perl program becomes C<WARN_VOID> when used in XS code and passed to one of 407the calls below. 408 409=for apidoc Am|bool|ckWARN|U32 w 410=for apidoc_item ||ckWARN2|U32 w1|U32 w2 411=for apidoc_item ||ckWARN3|U32 w1|U32 w2|U32 w3 412=for apidoc_item ||ckWARN4|U32 w1|U32 w2|U32 w3|U32 w4 413These return a boolean as to whether or not warnings are enabled for any of 414the warning category(ies) parameters: C<w>, C<w1>, .... 415 416Should any of the categories by default be enabled even if not within the 417scope of S<C<use warnings>>, instead use the C<L</ckWARN_d>> macros. 418 419The categories must be completely independent, one may not be subclassed from 420the other. 421 422=for apidoc Am|bool|ckWARN_d|U32 w 423=for apidoc_item ||ckWARN2_d|U32 w1|U32 w2 424=for apidoc_item ||ckWARN3_d|U32 w1|U32 w2|U32 w3 425=for apidoc_item ||ckWARN4_d|U32 w1|U32 w2|U32 w3|U32 w4 426 427Like C<L</ckWARN>>, but for use if and only if the warning category(ies) is by 428default enabled even if not within the scope of S<C<use warnings>>. 429 430=for apidoc Am|U32|packWARN|U32 w1 431=for apidoc_item ||packWARN2|U32 w1|U32 w2 432=for apidoc_item ||packWARN3|U32 w1|U32 w2|U32 w3 433=for apidoc_item ||packWARN4|U32 w1|U32 w2|U32 w3|U32 w4 434 435These macros are used to pack warning categories into a single U32 to pass to 436macros and functions that take a warning category parameter. The number of 437categories to pack is given by the name, with a corresponding number of 438category parameters passed. 439 440=cut 441 442*/ 443 444#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w)) 445 446/* The w1, w2 ... should be independent warnings categories; one shouldn't be 447 * a subcategory of any other */ 448 449#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2)) 450#define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3)) 451#define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4)) 452 453#define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w)) 454#define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2)) 455#define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3)) 456#define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4)) 457 458#define WARNshift 8 459 460#define packWARN(a) (a ) 461 462/* The a, b, ... should be independent warnings categories; one shouldn't be 463 * a subcategory of any other */ 464 465#define packWARN2(a,b) ((a) | ((b)<<8) ) 466#define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) ) 467#define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24)) 468 469#define unpackWARN1(x) ((U8) (x) ) 470#define unpackWARN2(x) ((U8) ((x) >> 8)) 471#define unpackWARN3(x) ((U8) ((x) >> 16)) 472#define unpackWARN4(x) ((U8) ((x) >> 24)) 473 474#define ckDEAD(x) \ 475 (PL_curcop && \ 476 !specialWARN(PL_curcop->cop_warnings) && \ 477 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \ 478 (unpackWARN2(x) && \ 479 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \ 480 (unpackWARN3(x) && \ 481 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \ 482 (unpackWARN4(x) && \ 483 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))))))) 484 485EOM 486 487 print $warn "\n\n/*\n" ; 488 print $warn map { "=for apidoc Amnh||$_\n" } @names; 489 print $warn "\n=cut\n*/\n\n" ; 490 print $warn "/* end of file warnings.h */\n"; 491 492 read_only_bottom_close_and_rename($warn); 493} 494 495while (<DATA>) { 496 last if /^VERSION$/ ; 497 print $pm $_ ; 498} 499 500print $pm qq(our \$VERSION = "$::VERSION";\n); 501 502while (<DATA>) { 503 last if /^KEYWORDS$/ ; 504 print $pm $_ ; 505} 506 507my $last_ver = 0; 508print $pm "our %Offsets = (" ; 509foreach my $k (sort { $a <=> $b } keys %ValueToName) { 510 my ($name, $version) = @{ $ValueToName{$k} }; 511 $name = lc $name; 512 $k *= 2 ; 513 if ( $last_ver != $version ) { 514 print $pm "\n"; 515 print $pm tab(6, " # Warnings Categories added in Perl $version"); 516 print $pm "\n"; 517 } 518 print $pm tab(6, " '$name'"), "=> $k,\n" ; 519 $last_ver = $version; 520} 521 522print $pm ");\n\n" ; 523 524print $pm "our %Bits = (\n" ; 525foreach my $k (sort keys %list) { 526 527 my $v = $list{$k} ; 528 my @list = sort { $a <=> $b } @$v ; 529 530 print $pm tab(6, " '$k'"), '=> "', 531 mkHex($warn_size, map $_ * 2 , @list), 532 '", # [', mkRange(@list), "]\n" ; 533} 534 535print $pm ");\n\n" ; 536 537print $pm "our %DeadBits = (\n" ; 538foreach my $k (sort keys %list) { 539 540 my $v = $list{$k} ; 541 my @list = sort { $a <=> $b } @$v ; 542 543 print $pm tab(6, " '$k'"), '=> "', 544 mkHex($warn_size, map $_ * 2 + 1 , @list), 545 '", # [', mkRange(@list), "]\n" ; 546} 547 548print $pm ");\n\n" ; 549print $pm "# These are used by various things, including our own tests\n"; 550print $pm tab(6, 'our $NONE'), '= "', ('\0' x $warn_size) , "\";\n" ; 551print $pm tab(6, 'our $DEFAULT'), '= "', mkHex($warn_size, map $_ * 2, @def), 552 '"; # [', mkRange(sort { $a <=> $b } @def), "]\n" ; 553print $pm tab(6, 'our $LAST_BIT'), '= ' . "$index ;\n" ; 554print $pm tab(6, 'our $BYTES'), '= ' . "$warn_size ;\n" ; 555while (<DATA>) { 556 if ($_ eq "=for warnings.pl tree-goes-here\n") { 557 print $pm warningsTree($tree, " "); 558 next; 559 } 560 print $pm $_ ; 561} 562 563read_only_bottom_close_and_rename($pm); 564 565__END__ 566package warnings; 567 568VERSION 569 570# Verify that we're called correctly so that warnings will work. 571# Can't use Carp, since Carp uses us! 572# String regexps because constant folding = smaller optree = less memory vs regexp literal 573# see also strict.pm. 574die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2] 575 if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' ) 576 && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' ); 577 578KEYWORDS 579 580sub Croaker 581{ 582 require Carp; # this initializes %CarpInternal 583 local $Carp::CarpInternal{'warnings'}; 584 delete $Carp::CarpInternal{'warnings'}; 585 Carp::croak(@_); 586} 587 588sub _expand_bits { 589 my $bits = shift; 590 my $want_len = ($LAST_BIT + 7) >> 3; 591 my $len = length($bits); 592 if ($len != $want_len) { 593 if ($bits eq "") { 594 $bits = "\x00" x $want_len; 595 } elsif ($len > $want_len) { 596 substr $bits, $want_len, $len-$want_len, ""; 597 } else { 598 my $x = vec($bits, $Offsets{all} >> 1, 2); 599 $x |= $x << 2; 600 $x |= $x << 4; 601 $bits .= chr($x) x ($want_len - $len); 602 } 603 } 604 return $bits; 605} 606 607sub _bits { 608 my $mask = shift ; 609 my $catmask ; 610 my $fatal = 0 ; 611 my $no_fatal = 0 ; 612 613 $mask = _expand_bits($mask); 614 foreach my $word ( @_ ) { 615 if ($word eq 'FATAL') { 616 $fatal = 1; 617 $no_fatal = 0; 618 } 619 elsif ($word eq 'NONFATAL') { 620 $fatal = 0; 621 $no_fatal = 1; 622 } 623 elsif ($catmask = $Bits{$word}) { 624 $mask |= $catmask ; 625 $mask |= $DeadBits{$word} if $fatal ; 626 $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ; 627 } 628 else 629 { Croaker("Unknown warnings category '$word'")} 630 } 631 632 return $mask ; 633} 634 635sub bits 636{ 637 # called from B::Deparse.pm 638 push @_, 'all' unless @_ ; 639 return _bits("", @_) ; 640} 641 642sub import 643{ 644 my $invocant = shift; 645 646 # append 'all' when implied (empty import list or after a lone 647 # "FATAL" or "NONFATAL") 648 push @_, 'all' 649 if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL')); 650 651 my @fatal = (); 652 foreach my $warning (@_) { 653 if($warning =~ /^(NON)?FATAL$/) { 654 @fatal = ($warning); 655 } elsif(substr($warning, 0, 1) ne '-') { 656 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; 657 ${^WARNING_BITS} = _bits($mask, @fatal, $warning); 658 } else { 659 $invocant->unimport(substr($warning, 1)); 660 } 661 } 662} 663 664sub unimport 665{ 666 shift; 667 668 my $catmask ; 669 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; 670 671 # append 'all' when implied (empty import list or after a lone "FATAL") 672 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL'; 673 674 $mask = _expand_bits($mask); 675 foreach my $word ( @_ ) { 676 if ($word eq 'FATAL') { 677 next; 678 } 679 elsif ($catmask = $Bits{$word}) { 680 $mask = ~(~$mask | $catmask | $DeadBits{$word}); 681 } 682 else 683 { Croaker("Unknown warnings category '$word'")} 684 } 685 686 ${^WARNING_BITS} = $mask ; 687} 688 689my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); 690 691sub LEVEL () { 8 }; 692sub MESSAGE () { 4 }; 693sub FATAL () { 2 }; 694sub NORMAL () { 1 }; 695 696sub __chk 697{ 698 my $category ; 699 my $offset ; 700 my $isobj = 0 ; 701 my $wanted = shift; 702 my $has_message = $wanted & MESSAGE; 703 my $has_level = $wanted & LEVEL ; 704 705 if ($has_level) { 706 if (@_ != ($has_message ? 3 : 2)) { 707 my $sub = (caller 1)[3]; 708 my $syntax = $has_message 709 ? "category, level, 'message'" 710 : 'category, level'; 711 Croaker("Usage: $sub($syntax)"); 712 } 713 } 714 elsif (not @_ == 1 || @_ == ($has_message ? 2 : 0)) { 715 my $sub = (caller 1)[3]; 716 my $syntax = $has_message ? "[category,] 'message'" : '[category]'; 717 Croaker("Usage: $sub($syntax)"); 718 } 719 720 my $message = pop if $has_message; 721 722 if (@_) { 723 # check the category supplied. 724 $category = shift ; 725 if (my $type = ref $category) { 726 Croaker("not an object") 727 if exists $builtin_type{$type}; 728 $category = $type; 729 $isobj = 1 ; 730 } 731 $offset = $Offsets{$category}; 732 Croaker("Unknown warnings category '$category'") 733 unless defined $offset; 734 } 735 else { 736 $category = (caller(1))[0] ; 737 $offset = $Offsets{$category}; 738 Croaker("package '$category' not registered for warnings") 739 unless defined $offset ; 740 } 741 742 my $i; 743 744 if ($isobj) { 745 my $pkg; 746 $i = 2; 747 while (do { { package DB; $pkg = (caller($i++))[0] } } ) { 748 last unless @DB::args && $DB::args[0] =~ /^$category=/ ; 749 } 750 $i -= 2 ; 751 } 752 elsif ($has_level) { 753 $i = 2 + shift; 754 } 755 else { 756 $i = _error_loc(); # see where Carp will allocate the error 757 } 758 759 # Default to 0 if caller returns nothing. Default to $DEFAULT if it 760 # explicitly returns undef. 761 my(@callers_bitmask) = (caller($i))[9] ; 762 my $callers_bitmask = 763 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ; 764 length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all}; 765 766 my @results; 767 foreach my $type (FATAL, NORMAL) { 768 next unless $wanted & $type; 769 770 push @results, vec($callers_bitmask, $offset + $type - 1, 1); 771 } 772 773 # &enabled and &fatal_enabled 774 return $results[0] unless $has_message; 775 776 # &warnif, and the category is neither enabled as warning nor as fatal 777 return if ($wanted & (NORMAL | FATAL | MESSAGE)) 778 == (NORMAL | FATAL | MESSAGE) 779 && !($results[0] || $results[1]); 780 781 # If we have an explicit level, bypass Carp. 782 if ($has_level and @callers_bitmask) { 783 # logic copied from util.c:mess_sv 784 my $stuff = " at " . join " line ", (caller $i)[1,2]; 785 $stuff .= sprintf ", <%s> %s %d", 786 *${^LAST_FH}{NAME}, 787 ($/ eq "\n" ? "line" : "chunk"), $. 788 if $. && ${^LAST_FH}; 789 die "$message$stuff.\n" if $results[0]; 790 return warn "$message$stuff.\n"; 791 } 792 793 require Carp; 794 Carp::croak($message) if $results[0]; 795 # will always get here for &warn. will only get here for &warnif if the 796 # category is enabled 797 Carp::carp($message); 798} 799 800sub _mkMask 801{ 802 my ($bit) = @_; 803 my $mask = ""; 804 805 vec($mask, $bit, 1) = 1; 806 return $mask; 807} 808 809sub register_categories 810{ 811 my @names = @_; 812 813 for my $name (@names) { 814 if (! defined $Bits{$name}) { 815 $Offsets{$name} = $LAST_BIT; 816 $Bits{$name} = _mkMask($LAST_BIT++); 817 $DeadBits{$name} = _mkMask($LAST_BIT++); 818 if (length($Bits{$name}) > length($Bits{all})) { 819 $Bits{all} .= "\x55"; 820 $DeadBits{all} .= "\xaa"; 821 } 822 } 823 } 824} 825 826sub _error_loc { 827 require Carp; 828 goto &Carp::short_error_loc; # don't introduce another stack frame 829} 830 831sub enabled 832{ 833 return __chk(NORMAL, @_); 834} 835 836sub fatal_enabled 837{ 838 return __chk(FATAL, @_); 839} 840 841sub warn 842{ 843 return __chk(FATAL | MESSAGE, @_); 844} 845 846sub warnif 847{ 848 return __chk(NORMAL | FATAL | MESSAGE, @_); 849} 850 851sub enabled_at_level 852{ 853 return __chk(NORMAL | LEVEL, @_); 854} 855 856sub fatal_enabled_at_level 857{ 858 return __chk(FATAL | LEVEL, @_); 859} 860 861sub warn_at_level 862{ 863 return __chk(FATAL | MESSAGE | LEVEL, @_); 864} 865 866sub warnif_at_level 867{ 868 return __chk(NORMAL | FATAL | MESSAGE | LEVEL, @_); 869} 870 871# These are not part of any public interface, so we can delete them to save 872# space. 873delete @warnings::{qw(NORMAL FATAL MESSAGE LEVEL)}; 874 8751; 876__END__ 877 878=head1 NAME 879 880warnings - Perl pragma to control optional warnings 881 882=head1 SYNOPSIS 883 884 use warnings; 885 no warnings; 886 887 # Standard warnings are enabled by use v5.35 or above 888 use v5.35; 889 890 use warnings "all"; 891 no warnings "uninitialized"; 892 893 # or equivalent to those last two ... 894 use warnings qw(all -uninitialized); 895 896 use warnings::register; 897 if (warnings::enabled()) { 898 warnings::warn("some warning"); 899 } 900 901 if (warnings::enabled("void")) { 902 warnings::warn("void", "some warning"); 903 } 904 905 if (warnings::enabled($object)) { 906 warnings::warn($object, "some warning"); 907 } 908 909 warnings::warnif("some warning"); 910 warnings::warnif("void", "some warning"); 911 warnings::warnif($object, "some warning"); 912 913=head1 DESCRIPTION 914 915The C<warnings> pragma gives control over which warnings are enabled in 916which parts of a Perl program. It's a more flexible alternative for 917both the command line flag B<-w> and the equivalent Perl variable, 918C<$^W>. 919 920This pragma works just like the C<strict> pragma. 921This means that the scope of the warning pragma is limited to the 922enclosing block. It also means that the pragma setting will not 923leak across files (via C<use>, C<require> or C<do>). This allows 924authors to independently define the degree of warning checks that will 925be applied to their module. 926 927By default, optional warnings are disabled, so any legacy code that 928doesn't attempt to control the warnings will work unchanged. 929 930All warnings are enabled in a block by either of these: 931 932 use warnings; 933 use warnings 'all'; 934 935Similarly all warnings are disabled in a block by either of these: 936 937 no warnings; 938 no warnings 'all'; 939 940For example, consider the code below: 941 942 use warnings; 943 my @x; 944 { 945 no warnings; 946 my $y = @x[0]; 947 } 948 my $z = @x[0]; 949 950The code in the enclosing block has warnings enabled, but the inner 951block has them disabled. In this case that means the assignment to the 952scalar C<$z> will trip the C<"Scalar value @x[0] better written as $x[0]"> 953warning, but the assignment to the scalar C<$y> will not. 954 955All warnings are enabled automatically within the scope of 956a C<L<use v5.35|perlfunc/use VERSION>> (or higher) declaration. 957 958=head2 Default Warnings and Optional Warnings 959 960Before the introduction of lexical warnings, Perl had two classes of 961warnings: mandatory and optional. 962 963As its name suggests, if your code tripped a mandatory warning, you 964would get a warning whether you wanted it or not. 965For example, the code below would always produce an C<"isn't numeric"> 966warning about the "2:". 967 968 my $x = "2:" + 3; 969 970With the introduction of lexical warnings, mandatory warnings now become 971I<default> warnings. The difference is that although the previously 972mandatory warnings are still enabled by default, they can then be 973subsequently enabled or disabled with the lexical warning pragma. For 974example, in the code below, an C<"isn't numeric"> warning will only 975be reported for the C<$x> variable. 976 977 my $x = "2:" + 3; 978 no warnings; 979 my $y = "2:" + 3; 980 981Note that neither the B<-w> flag or the C<$^W> can be used to 982disable/enable default warnings. They are still mandatory in this case. 983 984=head2 "Negative warnings" 985 986As a convenience, you can (as of Perl 5.34) pass arguments to the 987C<import()> method both positively and negatively. Negative warnings 988are those with a C<-> sign prepended to their names; positive warnings 989are anything else. This lets you turn on some warnings and turn off 990others in one command. So, assuming that you've already turned on a 991bunch of warnings but want to tweak them a bit in some block, you can 992do this: 993 994 { 995 use warnings qw(uninitialized -redefine); 996 ... 997 } 998 999which is equivalent to: 1000 1001 { 1002 use warnings qw(uninitialized); 1003 no warnings qw(redefine); 1004 ... 1005 } 1006 1007The argument list is processed in the order you specify. So, for example, if you 1008don't want to be warned about use of experimental features, except for C<somefeature> 1009that you really dislike, you can say this: 1010 1011 use warnings qw(all -experimental experimental::somefeature); 1012 1013which is equivalent to: 1014 1015 use warnings 'all'; 1016 no warnings 'experimental'; 1017 use warnings 'experimental::somefeature'; 1018 1019=head2 What's wrong with B<-w> and C<$^W> 1020 1021Although very useful, the big problem with using B<-w> on the command 1022line to enable warnings is that it is all or nothing. Take the typical 1023scenario when you are writing a Perl program. Parts of the code you 1024will write yourself, but it's very likely that you will make use of 1025pre-written Perl modules. If you use the B<-w> flag in this case, you 1026end up enabling warnings in pieces of code that you haven't written. 1027 1028Similarly, using C<$^W> to either disable or enable blocks of code is 1029fundamentally flawed. For a start, say you want to disable warnings in 1030a block of code. You might expect this to be enough to do the trick: 1031 1032 { 1033 local ($^W) = 0; 1034 my $x =+ 2; 1035 my $y; chop $y; 1036 } 1037 1038When this code is run with the B<-w> flag, a warning will be produced 1039for the C<$x> line: C<"Reversed += operator">. 1040 1041The problem is that Perl has both compile-time and run-time warnings. To 1042disable compile-time warnings you need to rewrite the code like this: 1043 1044 { 1045 BEGIN { $^W = 0 } 1046 my $x =+ 2; 1047 my $y; chop $y; 1048 } 1049 1050And note that unlike the first example, this will permanently set C<$^W> 1051since it cannot both run during compile-time and be localized to a 1052run-time block. 1053 1054The other big problem with C<$^W> is the way you can inadvertently 1055change the warning setting in unexpected places in your code. For example, 1056when the code below is run (without the B<-w> flag), the second call 1057to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas 1058the first will not. 1059 1060 sub doit 1061 { 1062 my $y; chop $y; 1063 } 1064 1065 doit(); 1066 1067 { 1068 local ($^W) = 1; 1069 doit() 1070 } 1071 1072This is a side-effect of C<$^W> being dynamically scoped. 1073 1074Lexical warnings get around these limitations by allowing finer control 1075over where warnings can or can't be tripped. 1076 1077=head2 Controlling Warnings from the Command Line 1078 1079There are three Command Line flags that can be used to control when 1080warnings are (or aren't) produced: 1081 1082=over 5 1083 1084=item B<-w> 1085X<-w> 1086 1087This is the existing flag. If the lexical warnings pragma is B<not> 1088used in any of your code, or any of the modules that you use, this flag 1089will enable warnings everywhere. See L</Backward Compatibility> for 1090details of how this flag interacts with lexical warnings. 1091 1092=item B<-W> 1093X<-W> 1094 1095If the B<-W> flag is used on the command line, it will enable all warnings 1096throughout the program regardless of whether warnings were disabled 1097locally using C<no warnings> or C<$^W =0>. 1098This includes all files that get 1099included via C<use>, C<require> or C<do>. 1100Think of it as the Perl equivalent of the "lint" command. 1101 1102=item B<-X> 1103X<-X> 1104 1105Does the exact opposite to the B<-W> flag, i.e. it disables all warnings. 1106 1107=back 1108 1109=head2 Backward Compatibility 1110 1111If you are used to working with a version of Perl prior to the 1112introduction of lexically scoped warnings, or have code that uses both 1113lexical warnings and C<$^W>, this section will describe how they interact. 1114 1115How Lexical Warnings interact with B<-w>/C<$^W>: 1116 1117=over 5 1118 1119=item 1. 1120 1121If none of the three command line flags (B<-w>, B<-W> or B<-X>) that 1122control warnings is used and neither C<$^W> nor the C<warnings> pragma 1123are used, then default warnings will be enabled and optional warnings 1124disabled. 1125This means that legacy code that doesn't attempt to control the warnings 1126will work unchanged. 1127 1128=item 2. 1129 1130The B<-w> flag just sets the global C<$^W> variable as in 5.005. This 1131means that any legacy code that currently relies on manipulating C<$^W> 1132to control warning behavior will still work as is. 1133 1134=item 3. 1135 1136Apart from now being a boolean, the C<$^W> variable operates in exactly 1137the same horrible uncontrolled global way, except that it cannot 1138disable/enable default warnings. 1139 1140=item 4. 1141 1142If a piece of code is under the control of the C<warnings> pragma, 1143both the C<$^W> variable and the B<-w> flag will be ignored for the 1144scope of the lexical warning. 1145 1146=item 5. 1147 1148The only way to override a lexical warnings setting is with the B<-W> 1149or B<-X> command line flags. 1150 1151=back 1152 1153The combined effect of 3 & 4 is that it will allow code which uses 1154the C<warnings> pragma to control the warning behavior of $^W-type 1155code (using a C<local $^W=0>) if it really wants to, but not vice-versa. 1156 1157=head2 Category Hierarchy 1158X<warning, categories> 1159 1160A hierarchy of "categories" have been defined to allow groups of warnings 1161to be enabled/disabled in isolation. 1162 1163The current hierarchy is: 1164 1165=for warnings.pl tree-goes-here 1166 1167Just like the "strict" pragma any of these categories can be combined 1168 1169 use warnings qw(void redefine); 1170 no warnings qw(io syntax untie); 1171 1172Also like the "strict" pragma, if there is more than one instance of the 1173C<warnings> pragma in a given scope the cumulative effect is additive. 1174 1175 use warnings qw(void); # only "void" warnings enabled 1176 ... 1177 use warnings qw(io); # only "void" & "io" warnings enabled 1178 ... 1179 no warnings qw(void); # only "io" warnings enabled 1180 1181To determine which category a specific warning has been assigned to see 1182L<perldiag>. 1183 1184Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a 1185sub-category of the "syntax" category. It is now a top-level category 1186in its own right. 1187 1188Note: Before 5.21.0, the "missing" lexical warnings category was 1189internally defined to be the same as the "uninitialized" category. It 1190is now a top-level category in its own right. 1191 1192=head2 Fatal Warnings 1193X<warning, fatal> 1194 1195The presence of the word "FATAL" in the category list will escalate 1196warnings in those categories into fatal errors in that lexical scope. 1197 1198B<NOTE:> FATAL warnings should be used with care, particularly 1199C<< FATAL => 'all' >>. 1200 1201Libraries using L<warnings::warn|/FUNCTIONS> for custom warning categories 1202generally don't expect L<warnings::warn|/FUNCTIONS> to be fatal and can wind up 1203in an unexpected state as a result. For XS modules issuing categorized 1204warnings, such unanticipated exceptions could also expose memory leak bugs. 1205 1206Moreover, the Perl interpreter itself has had serious bugs involving 1207fatalized warnings. For a summary of resolved and unresolved problems as 1208of January 2015, please see 1209L<this perl5-porters post|http://www.nntp.perl.org/group/perl.perl5.porters/2015/01/msg225235.html>. 1210 1211While some developers find fatalizing some warnings to be a useful 1212defensive programming technique, using C<< FATAL => 'all' >> to fatalize 1213all possible warning categories -- including custom ones -- is particularly 1214risky. Therefore, the use of C<< FATAL => 'all' >> is 1215L<discouraged|perlpolicy/discouraged>. 1216 1217The L<strictures|strictures/VERSION-2> module on CPAN offers one example of 1218a warnings subset that the module's authors believe is relatively safe to 1219fatalize. 1220 1221B<NOTE:> Users of FATAL warnings, especially those using 1222C<< FATAL => 'all' >>, should be fully aware that they are risking future 1223portability of their programs by doing so. Perl makes absolutely no 1224commitments to not introduce new warnings or warnings categories in the 1225future; indeed, we explicitly reserve the right to do so. Code that may 1226not warn now may warn in a future release of Perl if the Perl5 development 1227team deems it in the best interests of the community to do so. Should code 1228using FATAL warnings break due to the introduction of a new warning we will 1229NOT consider it an incompatible change. Users of FATAL warnings should 1230take special caution during upgrades to check to see if their code triggers 1231any new warnings and should pay particular attention to the fine print of 1232the documentation of the features they use to ensure they do not exploit 1233features that are documented as risky, deprecated, or unspecified, or where 1234the documentation says "so don't do that", or anything with the same sense 1235and spirit. Use of such features in combination with FATAL warnings is 1236ENTIRELY AT THE USER'S RISK. 1237 1238The following documentation describes how to use FATAL warnings but the 1239perl5 porters strongly recommend that you understand the risks before doing 1240so, especially for library code intended for use by others, as there is no 1241way for downstream users to change the choice of fatal categories. 1242 1243In the code below, the use of C<time>, C<length> 1244and C<join> can all produce a C<"Useless use of xxx in void context"> 1245warning. 1246 1247 use warnings; 1248 1249 time; 1250 1251 { 1252 use warnings FATAL => qw(void); 1253 length "abc"; 1254 } 1255 1256 join "", 1,2,3; 1257 1258 print "done\n"; 1259 1260When run it produces this output 1261 1262 Useless use of time in void context at fatal line 3. 1263 Useless use of length in void context at fatal line 7. 1264 1265The scope where C<length> is used has escalated the C<void> warnings 1266category into a fatal error, so the program terminates immediately when it 1267encounters the warning. 1268 1269To explicitly turn off a "FATAL" warning you just disable the warning 1270it is associated with. So, for example, to disable the "void" warning 1271in the example above, either of these will do the trick: 1272 1273 no warnings qw(void); 1274 no warnings FATAL => qw(void); 1275 1276If you want to downgrade a warning that has been escalated into a fatal 1277error back to a normal warning, you can use the "NONFATAL" keyword. For 1278example, the code below will promote all warnings into fatal errors, 1279except for those in the "syntax" category. 1280 1281 use warnings FATAL => 'all', NONFATAL => 'syntax'; 1282 1283As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can 1284use: 1285 1286 use v5.20; # Perl 5.20 or greater is required for the following 1287 use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';" 1288 1289However, you should still heed the guidance earlier in this section against 1290using C<use warnings FATAL => 'all';>. 1291 1292If you want your program to be compatible with versions of Perl before 12935.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In 1294previous versions of Perl, the behavior of the statements 1295C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and 1296C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if 1297they included the C<< => 'all' >> portion. As of 5.20, they do.) 1298 1299=head2 Reporting Warnings from a Module 1300X<warning, reporting> X<warning, registering> 1301 1302The C<warnings> pragma provides a number of functions that are useful for 1303module authors. These are used when you want to report a module-specific 1304warning to a calling module has enabled warnings via the C<warnings> 1305pragma. 1306 1307Consider the module C<MyMod::Abc> below. 1308 1309 package MyMod::Abc; 1310 1311 use warnings::register; 1312 1313 sub open { 1314 my $path = shift; 1315 if ($path !~ m#^/#) { 1316 warnings::warn("changing relative path to /var/abc") 1317 if warnings::enabled(); 1318 $path = "/var/abc/$path"; 1319 } 1320 } 1321 1322 1; 1323 1324The call to C<warnings::register> will create a new warnings category 1325called "MyMod::Abc", i.e. the new category name matches the current 1326package name. The C<open> function in the module will display a warning 1327message if it gets given a relative path as a parameter. This warnings 1328will only be displayed if the code that uses C<MyMod::Abc> has actually 1329enabled them with the C<warnings> pragma like below. 1330 1331 use MyMod::Abc; 1332 use warnings 'MyMod::Abc'; 1333 ... 1334 abc::open("../fred.txt"); 1335 1336It is also possible to test whether the pre-defined warnings categories are 1337set in the calling module with the C<warnings::enabled> function. Consider 1338this snippet of code: 1339 1340 package MyMod::Abc; 1341 1342 sub open { 1343 if (warnings::enabled("deprecated")) { 1344 warnings::warn("deprecated", 1345 "open is deprecated, use new instead"); 1346 } 1347 new(@_); 1348 } 1349 1350 sub new 1351 ... 1352 1; 1353 1354The function C<open> has been deprecated, so code has been included to 1355display a warning message whenever the calling module has (at least) the 1356"deprecated" warnings category enabled. Something like this, say. 1357 1358 use warnings 'deprecated'; 1359 use MyMod::Abc; 1360 ... 1361 MyMod::Abc::open($filename); 1362 1363Either the C<warnings::warn> or C<warnings::warnif> function should be 1364used to actually display the warnings message. This is because they can 1365make use of the feature that allows warnings to be escalated into fatal 1366errors. So in this case 1367 1368 use MyMod::Abc; 1369 use warnings FATAL => 'MyMod::Abc'; 1370 ... 1371 MyMod::Abc::open('../fred.txt'); 1372 1373the C<warnings::warnif> function will detect this and die after 1374displaying the warning message. 1375 1376The three warnings functions, C<warnings::warn>, C<warnings::warnif> 1377and C<warnings::enabled> can optionally take an object reference in place 1378of a category name. In this case the functions will use the class name 1379of the object as the warnings category. 1380 1381Consider this example: 1382 1383 package Original; 1384 1385 no warnings; 1386 use warnings::register; 1387 1388 sub new 1389 { 1390 my $class = shift; 1391 bless [], $class; 1392 } 1393 1394 sub check 1395 { 1396 my $self = shift; 1397 my $value = shift; 1398 1399 if ($value % 2 && warnings::enabled($self)) 1400 { warnings::warn($self, "Odd numbers are unsafe") } 1401 } 1402 1403 sub doit 1404 { 1405 my $self = shift; 1406 my $value = shift; 1407 $self->check($value); 1408 # ... 1409 } 1410 1411 1; 1412 1413 package Derived; 1414 1415 use warnings::register; 1416 use Original; 1417 our @ISA = qw( Original ); 1418 sub new 1419 { 1420 my $class = shift; 1421 bless [], $class; 1422 } 1423 1424 1425 1; 1426 1427The code below makes use of both modules, but it only enables warnings from 1428C<Derived>. 1429 1430 use Original; 1431 use Derived; 1432 use warnings 'Derived'; 1433 my $x = Original->new(); 1434 $x->doit(1); 1435 my $y = Derived->new(); 1436 $x->doit(1); 1437 1438When this code is run only the C<Derived> object, C<$y>, will generate 1439a warning. 1440 1441 Odd numbers are unsafe at main.pl line 7 1442 1443Notice also that the warning is reported at the line where the object is first 1444used. 1445 1446When registering new categories of warning, you can supply more names to 1447warnings::register like this: 1448 1449 package MyModule; 1450 use warnings::register qw(format precision); 1451 1452 ... 1453 1454 warnings::warnif('MyModule::format', '...'); 1455 1456=head1 FUNCTIONS 1457 1458Note: The functions with names ending in C<_at_level> were added in Perl 14595.28. 1460 1461=over 4 1462 1463=item use warnings::register 1464 1465Creates a new warnings category with the same name as the package where 1466the call to the pragma is used. 1467 1468=item warnings::enabled() 1469 1470Use the warnings category with the same name as the current package. 1471 1472Return TRUE if that warnings category is enabled in the calling module. 1473Otherwise returns FALSE. 1474 1475=item warnings::enabled($category) 1476 1477Return TRUE if the warnings category, C<$category>, is enabled in the 1478calling module. 1479Otherwise returns FALSE. 1480 1481=item warnings::enabled($object) 1482 1483Use the name of the class for the object reference, C<$object>, as the 1484warnings category. 1485 1486Return TRUE if that warnings category is enabled in the first scope 1487where the object is used. 1488Otherwise returns FALSE. 1489 1490=item warnings::enabled_at_level($category, $level) 1491 1492Like C<warnings::enabled>, but $level specifies the exact call frame, 0 1493being the immediate caller. 1494 1495=item warnings::fatal_enabled() 1496 1497Return TRUE if the warnings category with the same name as the current 1498package has been set to FATAL in the calling module. 1499Otherwise returns FALSE. 1500 1501=item warnings::fatal_enabled($category) 1502 1503Return TRUE if the warnings category C<$category> has been set to FATAL in 1504the calling module. 1505Otherwise returns FALSE. 1506 1507=item warnings::fatal_enabled($object) 1508 1509Use the name of the class for the object reference, C<$object>, as the 1510warnings category. 1511 1512Return TRUE if that warnings category has been set to FATAL in the first 1513scope where the object is used. 1514Otherwise returns FALSE. 1515 1516=item warnings::fatal_enabled_at_level($category, $level) 1517 1518Like C<warnings::fatal_enabled>, but $level specifies the exact call frame, 15190 being the immediate caller. 1520 1521=item warnings::warn($message) 1522 1523Print C<$message> to STDERR. 1524 1525Use the warnings category with the same name as the current package. 1526 1527If that warnings category has been set to "FATAL" in the calling module 1528then die. Otherwise return. 1529 1530=item warnings::warn($category, $message) 1531 1532Print C<$message> to STDERR. 1533 1534If the warnings category, C<$category>, has been set to "FATAL" in the 1535calling module then die. Otherwise return. 1536 1537=item warnings::warn($object, $message) 1538 1539Print C<$message> to STDERR. 1540 1541Use the name of the class for the object reference, C<$object>, as the 1542warnings category. 1543 1544If that warnings category has been set to "FATAL" in the scope where C<$object> 1545is first used then die. Otherwise return. 1546 1547=item warnings::warn_at_level($category, $level, $message) 1548 1549Like C<warnings::warn>, but $level specifies the exact call frame, 15500 being the immediate caller. 1551 1552=item warnings::warnif($message) 1553 1554Equivalent to: 1555 1556 if (warnings::enabled()) 1557 { warnings::warn($message) } 1558 1559=item warnings::warnif($category, $message) 1560 1561Equivalent to: 1562 1563 if (warnings::enabled($category)) 1564 { warnings::warn($category, $message) } 1565 1566=item warnings::warnif($object, $message) 1567 1568Equivalent to: 1569 1570 if (warnings::enabled($object)) 1571 { warnings::warn($object, $message) } 1572 1573=item warnings::warnif_at_level($category, $level, $message) 1574 1575Like C<warnings::warnif>, but $level specifies the exact call frame, 15760 being the immediate caller. 1577 1578=item warnings::register_categories(@names) 1579 1580This registers warning categories for the given names and is primarily for 1581use by the warnings::register pragma. 1582 1583=back 1584 1585See also L<perlmodlib/Pragmatic Modules> and L<perldiag>. 1586 1587=cut 1588