3 # Regenerate (overwriting only if changed):
8 # from information hardcoded into this script (the $tree hash), plus the
9 # template for warnings.pm in the DATA section.
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
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.
17 # This script is normally invoked from regen.pl.
22 require './regen/regen_lib.pl';
27 sub DEFAULT_ON () { 1 }
28 sub DEFAULT_OFF () { 2 }
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],
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],
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],
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],
78 'surrogate' => [ 5.013, DEFAULT_OFF],
79 'nonchar' => [ 5.013, DEFAULT_OFF],
80 'non_unicode' => [ 5.013, DEFAULT_OFF],
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::win32_perlio' =>
99 [ 5.021, DEFAULT_ON ],
100 'experimental::refaliasing' =>
101 [ 5.021, DEFAULT_ON ],
102 'experimental::re_strict' =>
103 [ 5.021, DEFAULT_ON ],
104 'experimental::const_attr' =>
105 [ 5.021, DEFAULT_ON ],
106 'experimental::bitwise' =>
107 [ 5.021, DEFAULT_ON ],
108 'experimental::declared_refs' =>
109 [ 5.025, DEFAULT_ON ],
110 'experimental::script_run' =>
111 [ 5.027, DEFAULT_ON ],
112 'experimental::alpha_assertions' =>
113 [ 5.027, DEFAULT_ON ],
114 'experimental::private_use' =>
115 [ 5.029, DEFAULT_ON ],
116 'experimental::uniprop_wildcards' =>
117 [ 5.029, DEFAULT_ON ],
118 'experimental::vlb' =>
119 [ 5.029, DEFAULT_ON ],
122 'missing' => [ 5.021, DEFAULT_OFF],
123 'redundant' => [ 5.021, DEFAULT_OFF],
124 'locale' => [ 5.021, DEFAULT_ON],
125 'shadow' => [ 5.027, DEFAULT_OFF],
127 #'default' => [ 5.008, DEFAULT_ON ],
144 foreach $k (sort keys %$tre) {
146 die "duplicate key $k\n" if defined $list{$k} ;
147 die "Value associated with key '$k' is not an ARRAY reference"
148 if !ref $v || ref $v ne 'ARRAY' ;
150 my ($ver, $rest) = @{ $v } ;
151 push @{ $v_list{$ver} }, $k;
154 { valueWalk ($rest) }
163 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
164 foreach my $name (@{ $v_list{$ver} } ) {
165 $ValueToName{ $index } = [ uc $name, $ver ] ;
166 $NameToValue{ uc $name } = $index ++ ;
173 ###########################################################################
181 foreach $k (sort keys %$tre) {
183 die "duplicate key $k\n" if defined $list{$k} ;
184 die "Can't find key '$k'"
185 if ! defined $NameToValue{uc $k} ;
186 push @{ $list{$k} }, $NameToValue{uc $k} ;
187 die "Value associated with key '$k' is not an ARRAY reference"
188 if !ref $v || ref $v ne 'ARRAY' ;
190 my ($ver, $rest) = @{ $v } ;
192 { push (@{ $list{$k} }, walk ($rest)) }
193 elsif ($rest == DEFAULT_ON)
194 { push @def, $NameToValue{uc $k} }
196 push @list, @{ $list{$k} } ;
202 ###########################################################################
209 for my $i (1 .. @a - 1) {
211 if $a[$i] == $a[$i - 1] + 1
212 && ($i >= @a - 1 || $a[$i] + 1 == $a[$i + 1] );
214 $out[-1] = $a[-1] if $out[-1] eq "..";
216 my $out = join(",",@out);
218 $out =~ s/,(\.\.,)+/../g ;
222 ###########################################################################
229 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
230 my @keys = sort keys %$tre ;
234 while ($k = shift @keys) {
236 die "Value associated with key '$k' is not an ARRAY reference"
237 if !ref $v || ref $v ne 'ARRAY' ;
241 $rv .= $prefix . "|\n" ;
242 $rv .= $prefix . "+- $k" ;
243 $offset = ' ' x ($max + 4) ;
246 $rv .= $prefix . "$k" ;
247 $offset = ' ' x ($max + 1) ;
250 my ($ver, $rest) = @{ $v } ;
253 my $bar = @keys ? "|" : " ";
254 $rv .= " -" . "-" x ($max - length $k ) . "+\n" ;
255 $rv .= warningsTree ($rest, $prefix . $bar . $offset )
264 ###########################################################################
268 my ($f, $max, @a) = @_ ;
269 my $mask = "\x00" x $max ;
273 vec($mask, $_, 1) = 1 ;
276 foreach (unpack("C*", $mask)) {
278 $string .= '\x' . sprintf("%2.2x", $_)
281 $string .= '\\' . sprintf("%o", $_)
290 return mkHexOct("x", $max, @a);
296 return mkHexOct("o", $max, @a);
299 ###########################################################################
301 if (@ARGV && $ARGV[0] eq "tree")
303 print warningsTree($tree, " ") ;
307 my ($warn, $pm) = map {
308 open_new($_, '>', { by => 'regen/warnings.pl' });
309 } 'warnings.h', 'lib/warnings.pm';
311 my ($index, $warn_size);
314 # generate warnings.h
318 #define Off(x) ((x) / 8)
319 #define Bit(x) (1 << ((x) % 8))
320 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
323 #define G_WARN_OFF 0 /* $^W == 0 */
324 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
325 #define G_WARN_ALL_ON 2 /* -W flag */
326 #define G_WARN_ALL_OFF 4 /* -X flag */
327 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
328 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
330 #define pWARN_STD NULL
331 #define pWARN_ALL (STRLEN *) &PL_WARN_ALL /* use warnings 'all' */
332 #define pWARN_NONE (STRLEN *) &PL_WARN_NONE /* no warnings 'all' */
334 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
337 /* if PL_warnhook is set to this value, then warnings die */
338 #define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
344 $index = orderValues();
346 die <<EOM if $index > 255 ;
347 Too many warnings categories -- max is 255
348 rewrite packWARN* & unpackWARN* macros
352 for (my $i = $index; $i & 3; $i++) {
353 push @{$list{all}}, $i;
357 $warn_size = int($index / 8) + ($index % 8 != 0) ;
362 foreach $k (sort { $a <=> $b } keys %ValueToName) {
363 my ($name, $version) = @{ $ValueToName{$k} };
364 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
365 if $last_ver != $version ;
367 $name = "WARN_$name";
368 print $warn tab(6, "#define $name"), " $k\n" ;
370 $last_ver = $version ;
372 print $warn "\n\n/*\n" ;
374 print $warn map { "=for apidoc Amnh||$_\n" } @names;
375 print $warn "\n=cut\n*/\n\n" ;
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" ;
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) (IsSet((U8 *)(c + 1), 2*(x)))
389 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
391 #define DUP_WARNINGS(p) Perl_dup_warnings(aTHX_ p)
395 =head1 Warning and Dieing
397 In all these calls, the C<U32 wI<n>> parameters are warning category
398 constants. You can see the ones currently available in
399 L<warnings/Category Hierarchy>, just capitalize all letters in the names
400 and prefix them by C<WARN_>. So, for example, the category C<void> used in a
401 perl program becomes C<WARN_VOID> when used in XS code and passed to one of
404 =for apidoc Am|bool|ckWARN|U32 w
406 Returns a boolean as to whether or not warnings are enabled for the warning
407 category C<w>. If the category is by default enabled even if not within the
408 scope of S<C<use warnings>>, instead use the L</ckWARN_d> macro.
410 =for apidoc Am|bool|ckWARN_d|U32 w
412 Like C<L</ckWARN>>, but for use if and only if the warning category is by
413 default enabled even if not within the scope of S<C<use warnings>>.
415 =for apidoc Am|bool|ckWARN2|U32 w1|U32 w2
417 Like C<L</ckWARN>>, but takes two warnings categories as input, and returns
418 TRUE if either is enabled. If either category is by default enabled even if
419 not within the scope of S<C<use warnings>>, instead use the L</ckWARN2_d>
420 macro. The categories must be completely independent, one may not be
421 subclassed from the other.
423 =for apidoc Am|bool|ckWARN2_d|U32 w1|U32 w2
425 Like C<L</ckWARN2>>, but for use if and only if either warning category is by
426 default enabled even if not within the scope of S<C<use warnings>>.
428 =for apidoc Am|bool|ckWARN3|U32 w1|U32 w2|U32 w3
430 Like C<L</ckWARN2>>, but takes three warnings categories as input, and returns
431 TRUE if any is enabled. If any of the categories is by default enabled even
432 if not within the scope of S<C<use warnings>>, instead use the L</ckWARN3_d>
433 macro. The categories must be completely independent, one may not be
434 subclassed from any other.
436 =for apidoc Am|bool|ckWARN3_d|U32 w1|U32 w2|U32 w3
438 Like C<L</ckWARN3>>, but for use if and only if any of the warning categories
439 is by default enabled even if not within the scope of S<C<use warnings>>.
441 =for apidoc Am|bool|ckWARN4|U32 w1|U32 w2|U32 w3|U32 w4
443 Like C<L</ckWARN3>>, but takes four warnings categories as input, and returns
444 TRUE if any is enabled. If any of the categories is by default enabled even
445 if not within the scope of S<C<use warnings>>, instead use the L</ckWARN4_d>
446 macro. The categories must be completely independent, one may not be
447 subclassed from any other.
449 =for apidoc Am|bool|ckWARN4_d|U32 w1|U32 w2|U32 w3|U32 w4
451 Like C<L</ckWARN4>>, but for use if and only if any of the warning categories
452 is by default enabled even if not within the scope of S<C<use warnings>>.
458 #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
460 /* The w1, w2 ... should be independent warnings categories; one shouldn't be
461 * a subcategory of any other */
463 #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
464 #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
465 #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
467 #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
468 #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
469 #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
470 #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
474 #define packWARN(a) (a )
476 /* The a, b, ... should be independent warnings categories; one shouldn't be
477 * a subcategory of any other */
479 #define packWARN2(a,b) ((a) | ((b)<<8) )
480 #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
481 #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
483 #define unpackWARN1(x) ((x) & 0xFF)
484 #define unpackWARN2(x) (((x) >>8) & 0xFF)
485 #define unpackWARN3(x) (((x) >>16) & 0xFF)
486 #define unpackWARN4(x) (((x) >>24) & 0xFF)
490 !specialWARN(PL_curcop->cop_warnings) && \
491 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
493 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
495 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
497 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))))))))
499 /* end of file warnings.h */
502 read_only_bottom_close_and_rename($warn);
506 last if /^VERSION$/ ;
510 print $pm qq(our \$VERSION = "$::VERSION";\n);
513 last if /^KEYWORDS$/ ;
518 print $pm "our %Offsets = (" ;
519 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
520 my ($name, $version) = @{ $ValueToName{$k} };
523 if ( $last_ver != $version ) {
525 print $pm tab(6, " # Warnings Categories added in Perl $version");
528 print $pm tab(6, " '$name'"), "=> $k,\n" ;
529 $last_ver = $version;
534 print $pm "our %Bits = (\n" ;
535 foreach my $k (sort keys %list) {
538 my @list = sort { $a <=> $b } @$v ;
540 print $pm tab(6, " '$k'"), '=> "',
541 mkHex($warn_size, map $_ * 2 , @list),
542 '", # [', mkRange(@list), "]\n" ;
547 print $pm "our %DeadBits = (\n" ;
548 foreach my $k (sort keys %list) {
551 my @list = sort { $a <=> $b } @$v ;
553 print $pm tab(6, " '$k'"), '=> "',
554 mkHex($warn_size, map $_ * 2 + 1 , @list),
555 '", # [', mkRange(@list), "]\n" ;
559 print $pm "# These are used by various things, including our own tests\n";
560 print $pm tab(6, 'our $NONE'), '= "', ('\0' x $warn_size) , "\";\n" ;
561 print $pm tab(6, 'our $DEFAULT'), '= "', mkHex($warn_size, map $_ * 2, @def),
562 '", # [', mkRange(sort { $a <=> $b } @def), "]\n" ;
563 print $pm tab(6, 'our $LAST_BIT'), '= ' . "$index ;\n" ;
564 print $pm tab(6, 'our $BYTES'), '= ' . "$warn_size ;\n" ;
566 if ($_ eq "=for warnings.pl tree-goes-here\n") {
567 print $pm warningsTree($tree, " ");
573 read_only_bottom_close_and_rename($pm);
580 # Verify that we're called correctly so that warnings will work.
581 # Can't use Carp, since Carp uses us!
582 # String regexps because constant folding = smaller optree = less memory vs regexp literal
583 # see also strict.pm.
584 die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2]
585 if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' )
586 && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' );
592 require Carp; # this initializes %CarpInternal
593 local $Carp::CarpInternal{'warnings'};
594 delete $Carp::CarpInternal{'warnings'};
600 my $want_len = ($LAST_BIT + 7) >> 3;
601 my $len = length($bits);
602 if ($len != $want_len) {
604 $bits = "\x00" x $want_len;
605 } elsif ($len > $want_len) {
606 substr $bits, $want_len, $len-$want_len, "";
608 my $a = vec($bits, $Offsets{all} >> 1, 2);
611 $bits .= chr($a) x ($want_len - $len);
623 $mask = _expand_bits($mask);
624 foreach my $word ( @_ ) {
625 if ($word eq 'FATAL') {
629 elsif ($word eq 'NONFATAL') {
633 elsif ($catmask = $Bits{$word}) {
635 $mask |= $DeadBits{$word} if $fatal ;
636 $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ;
639 { Croaker("Unknown warnings category '$word'")}
647 # called from B::Deparse.pm
648 push @_, 'all' unless @_ ;
649 return _bits("", @_) ;
656 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
658 # append 'all' when implied (empty import list or after a lone
659 # "FATAL" or "NONFATAL")
661 if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL'));
663 ${^WARNING_BITS} = _bits($mask, @_);
671 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
673 # append 'all' when implied (empty import list or after a lone "FATAL")
674 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
676 $mask = _expand_bits($mask);
677 foreach my $word ( @_ ) {
678 if ($word eq 'FATAL') {
681 elsif ($catmask = $Bits{$word}) {
682 $mask = ~(~$mask | $catmask | $DeadBits{$word});
685 { Croaker("Unknown warnings category '$word'")}
688 ${^WARNING_BITS} = $mask ;
691 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
694 sub MESSAGE () { 4 };
704 my $has_message = $wanted & MESSAGE;
705 my $has_level = $wanted & LEVEL ;
708 if (@_ != ($has_message ? 3 : 2)) {
709 my $sub = (caller 1)[3];
710 my $syntax = $has_message
711 ? "category, level, 'message'"
713 Croaker("Usage: $sub($syntax)");
716 elsif (not @_ == 1 || @_ == ($has_message ? 2 : 0)) {
717 my $sub = (caller 1)[3];
718 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
719 Croaker("Usage: $sub($syntax)");
722 my $message = pop if $has_message;
725 # check the category supplied.
727 if (my $type = ref $category) {
728 Croaker("not an object")
729 if exists $builtin_type{$type};
733 $offset = $Offsets{$category};
734 Croaker("Unknown warnings category '$category'")
735 unless defined $offset;
738 $category = (caller(1))[0] ;
739 $offset = $Offsets{$category};
740 Croaker("package '$category' not registered for warnings")
741 unless defined $offset ;
749 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
750 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
758 $i = _error_loc(); # see where Carp will allocate the error
761 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
762 # explicitly returns undef.
763 my(@callers_bitmask) = (caller($i))[9] ;
764 my $callers_bitmask =
765 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
766 length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all};
769 foreach my $type (FATAL, NORMAL) {
770 next unless $wanted & $type;
772 push @results, vec($callers_bitmask, $offset + $type - 1, 1);
775 # &enabled and &fatal_enabled
776 return $results[0] unless $has_message;
778 # &warnif, and the category is neither enabled as warning nor as fatal
779 return if ($wanted & (NORMAL | FATAL | MESSAGE))
780 == (NORMAL | FATAL | MESSAGE)
781 && !($results[0] || $results[1]);
783 # If we have an explicit level, bypass Carp.
784 if ($has_level and @callers_bitmask) {
785 # logic copied from util.c:mess_sv
786 my $stuff = " at " . join " line ", (caller $i)[1,2];
787 $stuff .= sprintf ", <%s> %s %d",
789 ($/ eq "\n" ? "line" : "chunk"), $.
790 if $. && ${^LAST_FH};
791 die "$message$stuff.\n" if $results[0];
792 return warn "$message$stuff.\n";
796 Carp::croak($message) if $results[0];
797 # will always get here for &warn. will only get here for &warnif if the
798 # category is enabled
799 Carp::carp($message);
807 vec($mask, $bit, 1) = 1;
811 sub register_categories
815 for my $name (@names) {
816 if (! defined $Bits{$name}) {
817 $Offsets{$name} = $LAST_BIT;
818 $Bits{$name} = _mkMask($LAST_BIT++);
819 $DeadBits{$name} = _mkMask($LAST_BIT++);
820 if (length($Bits{$name}) > length($Bits{all})) {
821 $Bits{all} .= "\x55";
822 $DeadBits{all} .= "\xaa";
830 goto &Carp::short_error_loc; # don't introduce another stack frame
835 return __chk(NORMAL, @_);
840 return __chk(FATAL, @_);
845 return __chk(FATAL | MESSAGE, @_);
850 return __chk(NORMAL | FATAL | MESSAGE, @_);
855 return __chk(NORMAL | LEVEL, @_);
858 sub fatal_enabled_at_level
860 return __chk(FATAL | LEVEL, @_);
865 return __chk(FATAL | MESSAGE | LEVEL, @_);
870 return __chk(NORMAL | FATAL | MESSAGE | LEVEL, @_);
873 # These are not part of any public interface, so we can delete them to save
875 delete @warnings::{qw(NORMAL FATAL MESSAGE LEVEL)};
882 warnings - Perl pragma to control optional warnings
892 use warnings::register;
893 if (warnings::enabled()) {
894 warnings::warn("some warning");
897 if (warnings::enabled("void")) {
898 warnings::warn("void", "some warning");
901 if (warnings::enabled($object)) {
902 warnings::warn($object, "some warning");
905 warnings::warnif("some warning");
906 warnings::warnif("void", "some warning");
907 warnings::warnif($object, "some warning");
911 The C<warnings> pragma gives control over which warnings are enabled in
912 which parts of a Perl program. It's a more flexible alternative for
913 both the command line flag B<-w> and the equivalent Perl variable,
916 This pragma works just like the C<strict> pragma.
917 This means that the scope of the warning pragma is limited to the
918 enclosing block. It also means that the pragma setting will not
919 leak across files (via C<use>, C<require> or C<do>). This allows
920 authors to independently define the degree of warning checks that will
921 be applied to their module.
923 By default, optional warnings are disabled, so any legacy code that
924 doesn't attempt to control the warnings will work unchanged.
926 All warnings are enabled in a block by either of these:
931 Similarly all warnings are disabled in a block by either of these:
936 For example, consider the code below:
946 The code in the enclosing block has warnings enabled, but the inner
947 block has them disabled. In this case that means the assignment to the
948 scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]">
949 warning, but the assignment to the scalar C<$b> will not.
951 =head2 Default Warnings and Optional Warnings
953 Before the introduction of lexical warnings, Perl had two classes of
954 warnings: mandatory and optional.
956 As its name suggests, if your code tripped a mandatory warning, you
957 would get a warning whether you wanted it or not.
958 For example, the code below would always produce an C<"isn't numeric">
959 warning about the "2:".
963 With the introduction of lexical warnings, mandatory warnings now become
964 I<default> warnings. The difference is that although the previously
965 mandatory warnings are still enabled by default, they can then be
966 subsequently enabled or disabled with the lexical warning pragma. For
967 example, in the code below, an C<"isn't numeric"> warning will only
968 be reported for the C<$a> variable.
974 Note that neither the B<-w> flag or the C<$^W> can be used to
975 disable/enable default warnings. They are still mandatory in this case.
977 =head2 What's wrong with B<-w> and C<$^W>
979 Although very useful, the big problem with using B<-w> on the command
980 line to enable warnings is that it is all or nothing. Take the typical
981 scenario when you are writing a Perl program. Parts of the code you
982 will write yourself, but it's very likely that you will make use of
983 pre-written Perl modules. If you use the B<-w> flag in this case, you
984 end up enabling warnings in pieces of code that you haven't written.
986 Similarly, using C<$^W> to either disable or enable blocks of code is
987 fundamentally flawed. For a start, say you want to disable warnings in
988 a block of code. You might expect this to be enough to do the trick:
996 When this code is run with the B<-w> flag, a warning will be produced
997 for the C<$a> line: C<"Reversed += operator">.
999 The problem is that Perl has both compile-time and run-time warnings. To
1000 disable compile-time warnings you need to rewrite the code like this:
1008 The other big problem with C<$^W> is the way you can inadvertently
1009 change the warning setting in unexpected places in your code. For example,
1010 when the code below is run (without the B<-w> flag), the second call
1011 to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
1026 This is a side-effect of C<$^W> being dynamically scoped.
1028 Lexical warnings get around these limitations by allowing finer control
1029 over where warnings can or can't be tripped.
1031 =head2 Controlling Warnings from the Command Line
1033 There are three Command Line flags that can be used to control when
1034 warnings are (or aren't) produced:
1041 This is the existing flag. If the lexical warnings pragma is B<not>
1042 used in any of you code, or any of the modules that you use, this flag
1043 will enable warnings everywhere. See L</Backward Compatibility> for
1044 details of how this flag interacts with lexical warnings.
1049 If the B<-W> flag is used on the command line, it will enable all warnings
1050 throughout the program regardless of whether warnings were disabled
1051 locally using C<no warnings> or C<$^W =0>.
1052 This includes all files that get
1053 included via C<use>, C<require> or C<do>.
1054 Think of it as the Perl equivalent of the "lint" command.
1059 Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
1063 =head2 Backward Compatibility
1065 If you are used to working with a version of Perl prior to the
1066 introduction of lexically scoped warnings, or have code that uses both
1067 lexical warnings and C<$^W>, this section will describe how they interact.
1069 How Lexical Warnings interact with B<-w>/C<$^W>:
1075 If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
1076 control warnings is used and neither C<$^W> nor the C<warnings> pragma
1077 are used, then default warnings will be enabled and optional warnings
1079 This means that legacy code that doesn't attempt to control the warnings
1080 will work unchanged.
1084 The B<-w> flag just sets the global C<$^W> variable as in 5.005. This
1085 means that any legacy code that currently relies on manipulating C<$^W>
1086 to control warning behavior will still work as is.
1090 Apart from now being a boolean, the C<$^W> variable operates in exactly
1091 the same horrible uncontrolled global way, except that it cannot
1092 disable/enable default warnings.
1096 If a piece of code is under the control of the C<warnings> pragma,
1097 both the C<$^W> variable and the B<-w> flag will be ignored for the
1098 scope of the lexical warning.
1102 The only way to override a lexical warnings setting is with the B<-W>
1103 or B<-X> command line flags.
1107 The combined effect of 3 & 4 is that it will allow code which uses
1108 the C<warnings> pragma to control the warning behavior of $^W-type
1109 code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
1111 =head2 Category Hierarchy
1112 X<warning, categories>
1114 A hierarchy of "categories" have been defined to allow groups of warnings
1115 to be enabled/disabled in isolation.
1117 The current hierarchy is:
1119 =for warnings.pl tree-goes-here
1121 Just like the "strict" pragma any of these categories can be combined
1123 use warnings qw(void redefine);
1124 no warnings qw(io syntax untie);
1126 Also like the "strict" pragma, if there is more than one instance of the
1127 C<warnings> pragma in a given scope the cumulative effect is additive.
1129 use warnings qw(void); # only "void" warnings enabled
1131 use warnings qw(io); # only "void" & "io" warnings enabled
1133 no warnings qw(void); # only "io" warnings enabled
1135 To determine which category a specific warning has been assigned to see
1138 Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
1139 sub-category of the "syntax" category. It is now a top-level category
1142 Note: Before 5.21.0, the "missing" lexical warnings category was
1143 internally defined to be the same as the "uninitialized" category. It
1144 is now a top-level category in its own right.
1146 =head2 Fatal Warnings
1149 The presence of the word "FATAL" in the category list will escalate
1150 warnings in those categories into fatal errors in that lexical scope.
1152 B<NOTE:> FATAL warnings should be used with care, particularly
1153 C<< FATAL => 'all' >>.
1155 Libraries using L<warnings::warn|/FUNCTIONS> for custom warning categories
1156 generally don't expect L<warnings::warn|/FUNCTIONS> to be fatal and can wind up
1157 in an unexpected state as a result. For XS modules issuing categorized
1158 warnings, such unanticipated exceptions could also expose memory leak bugs.
1160 Moreover, the Perl interpreter itself has had serious bugs involving
1161 fatalized warnings. For a summary of resolved and unresolved problems as
1162 of January 2015, please see
1163 L<this perl5-porters post|http://www.nntp.perl.org/group/perl.perl5.porters/2015/01/msg225235.html>.
1165 While some developers find fatalizing some warnings to be a useful
1166 defensive programming technique, using C<< FATAL => 'all' >> to fatalize
1167 all possible warning categories -- including custom ones -- is particularly
1168 risky. Therefore, the use of C<< FATAL => 'all' >> is
1169 L<discouraged|perlpolicy/discouraged>.
1171 The L<strictures|strictures/VERSION-2> module on CPAN offers one example of
1172 a warnings subset that the module's authors believe is relatively safe to
1175 B<NOTE:> users of FATAL warnings, especially those using
1176 C<< FATAL => 'all' >>, should be fully aware that they are risking future
1177 portability of their programs by doing so. Perl makes absolutely no
1178 commitments to not introduce new warnings or warnings categories in the
1179 future; indeed, we explicitly reserve the right to do so. Code that may
1180 not warn now may warn in a future release of Perl if the Perl5 development
1181 team deems it in the best interests of the community to do so. Should code
1182 using FATAL warnings break due to the introduction of a new warning we will
1183 NOT consider it an incompatible change. Users of FATAL warnings should
1184 take special caution during upgrades to check to see if their code triggers
1185 any new warnings and should pay particular attention to the fine print of
1186 the documentation of the features they use to ensure they do not exploit
1187 features that are documented as risky, deprecated, or unspecified, or where
1188 the documentation says "so don't do that", or anything with the same sense
1189 and spirit. Use of such features in combination with FATAL warnings is
1190 ENTIRELY AT THE USER'S RISK.
1192 The following documentation describes how to use FATAL warnings but the
1193 perl5 porters strongly recommend that you understand the risks before doing
1194 so, especially for library code intended for use by others, as there is no
1195 way for downstream users to change the choice of fatal categories.
1197 In the code below, the use of C<time>, C<length>
1198 and C<join> can all produce a C<"Useless use of xxx in void context">
1206 use warnings FATAL => qw(void);
1214 When run it produces this output
1216 Useless use of time in void context at fatal line 3.
1217 Useless use of length in void context at fatal line 7.
1219 The scope where C<length> is used has escalated the C<void> warnings
1220 category into a fatal error, so the program terminates immediately when it
1221 encounters the warning.
1223 To explicitly turn off a "FATAL" warning you just disable the warning
1224 it is associated with. So, for example, to disable the "void" warning
1225 in the example above, either of these will do the trick:
1227 no warnings qw(void);
1228 no warnings FATAL => qw(void);
1230 If you want to downgrade a warning that has been escalated into a fatal
1231 error back to a normal warning, you can use the "NONFATAL" keyword. For
1232 example, the code below will promote all warnings into fatal errors,
1233 except for those in the "syntax" category.
1235 use warnings FATAL => 'all', NONFATAL => 'syntax';
1237 As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
1240 use v5.20; # Perl 5.20 or greater is required for the following
1241 use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';"
1243 If you want your program to be compatible with versions of Perl before
1244 5.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In
1245 previous versions of Perl, the behavior of the statements
1246 C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
1247 C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
1248 they included the C<< => 'all' >> portion. As of 5.20, they do.)
1250 =head2 Reporting Warnings from a Module
1251 X<warning, reporting> X<warning, registering>
1253 The C<warnings> pragma provides a number of functions that are useful for
1254 module authors. These are used when you want to report a module-specific
1255 warning to a calling module has enabled warnings via the C<warnings>
1258 Consider the module C<MyMod::Abc> below.
1262 use warnings::register;
1266 if ($path !~ m#^/#) {
1267 warnings::warn("changing relative path to /var/abc")
1268 if warnings::enabled();
1269 $path = "/var/abc/$path";
1275 The call to C<warnings::register> will create a new warnings category
1276 called "MyMod::Abc", i.e. the new category name matches the current
1277 package name. The C<open> function in the module will display a warning
1278 message if it gets given a relative path as a parameter. This warnings
1279 will only be displayed if the code that uses C<MyMod::Abc> has actually
1280 enabled them with the C<warnings> pragma like below.
1283 use warnings 'MyMod::Abc';
1285 abc::open("../fred.txt");
1287 It is also possible to test whether the pre-defined warnings categories are
1288 set in the calling module with the C<warnings::enabled> function. Consider
1289 this snippet of code:
1294 if (warnings::enabled("deprecated")) {
1295 warnings::warn("deprecated",
1296 "open is deprecated, use new instead");
1305 The function C<open> has been deprecated, so code has been included to
1306 display a warning message whenever the calling module has (at least) the
1307 "deprecated" warnings category enabled. Something like this, say.
1309 use warnings 'deprecated';
1312 MyMod::Abc::open($filename);
1314 Either the C<warnings::warn> or C<warnings::warnif> function should be
1315 used to actually display the warnings message. This is because they can
1316 make use of the feature that allows warnings to be escalated into fatal
1317 errors. So in this case
1320 use warnings FATAL => 'MyMod::Abc';
1322 MyMod::Abc::open('../fred.txt');
1324 the C<warnings::warnif> function will detect this and die after
1325 displaying the warning message.
1327 The three warnings functions, C<warnings::warn>, C<warnings::warnif>
1328 and C<warnings::enabled> can optionally take an object reference in place
1329 of a category name. In this case the functions will use the class name
1330 of the object as the warnings category.
1332 Consider this example:
1337 use warnings::register;
1350 if ($value % 2 && warnings::enabled($self))
1351 { warnings::warn($self, "Odd numbers are unsafe") }
1358 $self->check($value);
1366 use warnings::register;
1368 our @ISA = qw( Original );
1378 The code below makes use of both modules, but it only enables warnings from
1383 use warnings 'Derived';
1384 my $a = Original->new();
1386 my $b = Derived->new();
1389 When this code is run only the C<Derived> object, C<$b>, will generate
1392 Odd numbers are unsafe at main.pl line 7
1394 Notice also that the warning is reported at the line where the object is first
1397 When registering new categories of warning, you can supply more names to
1398 warnings::register like this:
1401 use warnings::register qw(format precision);
1405 warnings::warnif('MyModule::format', '...');
1409 Note: The functions with names ending in C<_at_level> were added in Perl
1414 =item use warnings::register
1416 Creates a new warnings category with the same name as the package where
1417 the call to the pragma is used.
1419 =item warnings::enabled()
1421 Use the warnings category with the same name as the current package.
1423 Return TRUE if that warnings category is enabled in the calling module.
1424 Otherwise returns FALSE.
1426 =item warnings::enabled($category)
1428 Return TRUE if the warnings category, C<$category>, is enabled in the
1430 Otherwise returns FALSE.
1432 =item warnings::enabled($object)
1434 Use the name of the class for the object reference, C<$object>, as the
1437 Return TRUE if that warnings category is enabled in the first scope
1438 where the object is used.
1439 Otherwise returns FALSE.
1441 =item warnings::enabled_at_level($category, $level)
1443 Like C<warnings::enabled>, but $level specifies the exact call frame, 0
1444 being the immediate caller.
1446 =item warnings::fatal_enabled()
1448 Return TRUE if the warnings category with the same name as the current
1449 package has been set to FATAL in the calling module.
1450 Otherwise returns FALSE.
1452 =item warnings::fatal_enabled($category)
1454 Return TRUE if the warnings category C<$category> has been set to FATAL in
1456 Otherwise returns FALSE.
1458 =item warnings::fatal_enabled($object)
1460 Use the name of the class for the object reference, C<$object>, as the
1463 Return TRUE if that warnings category has been set to FATAL in the first
1464 scope where the object is used.
1465 Otherwise returns FALSE.
1467 =item warnings::fatal_enabled_at_level($category, $level)
1469 Like C<warnings::fatal_enabled>, but $level specifies the exact call frame,
1470 0 being the immediate caller.
1472 =item warnings::warn($message)
1474 Print C<$message> to STDERR.
1476 Use the warnings category with the same name as the current package.
1478 If that warnings category has been set to "FATAL" in the calling module
1479 then die. Otherwise return.
1481 =item warnings::warn($category, $message)
1483 Print C<$message> to STDERR.
1485 If the warnings category, C<$category>, has been set to "FATAL" in the
1486 calling module then die. Otherwise return.
1488 =item warnings::warn($object, $message)
1490 Print C<$message> to STDERR.
1492 Use the name of the class for the object reference, C<$object>, as the
1495 If that warnings category has been set to "FATAL" in the scope where C<$object>
1496 is first used then die. Otherwise return.
1498 =item warnings::warn_at_level($category, $level, $message)
1500 Like C<warnings::warn>, but $level specifies the exact call frame,
1501 0 being the immediate caller.
1503 =item warnings::warnif($message)
1507 if (warnings::enabled())
1508 { warnings::warn($message) }
1510 =item warnings::warnif($category, $message)
1514 if (warnings::enabled($category))
1515 { warnings::warn($category, $message) }
1517 =item warnings::warnif($object, $message)
1521 if (warnings::enabled($object))
1522 { warnings::warn($object, $message) }
1524 =item warnings::warnif_at_level($category, $level, $message)
1526 Like C<warnings::warnif>, but $level specifies the exact call frame,
1527 0 being the immediate caller.
1529 =item warnings::register_categories(@names)
1531 This registers warning categories for the given names and is primarily for
1532 use by the warnings::register pragma.
1536 See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.