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_OFF ],
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 'experimental::for_list' =>
125 [ 5.035, DEFAULT_ON ],
126 'experimental::builtin' =>
127 [ 5.035, DEFAULT_ON ],
128 'experimental::args_array_with_signatures' =>
129 [ 5.035, DEFAULT_ON],
130 'experimental::extra_paired_delimiters' =>
131 [ 5.035, DEFAULT_ON],
134 'missing' => [ 5.021, DEFAULT_OFF],
135 'redundant' => [ 5.021, DEFAULT_OFF],
136 'locale' => [ 5.021, DEFAULT_ON],
137 'shadow' => [ 5.027, DEFAULT_OFF],
138 'scalar' => [ 5.035, DEFAULT_OFF],
140 #'default' => [ 5.008, DEFAULT_ON ],
157 foreach $k (sort keys %$tre) {
159 die "duplicate key $k\n" if defined $list{$k} ;
160 die "Value associated with key '$k' is not an ARRAY reference"
161 if !ref $v || ref $v ne 'ARRAY' ;
163 my ($ver, $rest) = @{ $v } ;
164 push @{ $v_list{$ver} }, $k;
167 { valueWalk ($rest) }
176 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
177 foreach my $name (@{ $v_list{$ver} } ) {
178 $ValueToName{ $index } = [ uc $name, $ver ] ;
179 $NameToValue{ uc $name } = $index ++ ;
186 ###########################################################################
194 foreach $k (sort keys %$tre) {
196 die "duplicate key $k\n" if defined $list{$k} ;
197 die "Can't find key '$k'"
198 if ! defined $NameToValue{uc $k} ;
199 push @{ $list{$k} }, $NameToValue{uc $k} ;
200 die "Value associated with key '$k' is not an ARRAY reference"
201 if !ref $v || ref $v ne 'ARRAY' ;
203 my ($ver, $rest) = @{ $v } ;
205 { push (@{ $list{$k} }, walk ($rest)) }
206 elsif ($rest == DEFAULT_ON)
207 { push @def, $NameToValue{uc $k} }
209 push @list, @{ $list{$k} } ;
215 ###########################################################################
222 for my $i (1 .. @in - 1) {
224 if $in[$i] == $in[$i - 1] + 1
225 && ($i >= @in - 1 || $in[$i] + 1 == $in[$i + 1] );
227 $out[-1] = $in[-1] if $out[-1] eq "..";
229 my $out = join(",",@out);
231 $out =~ s/,(\.\.,)+/../g ;
235 ###########################################################################
242 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
243 my @keys = sort keys %$tre ;
247 while ($k = shift @keys) {
249 die "Value associated with key '$k' is not an ARRAY reference"
250 if !ref $v || ref $v ne 'ARRAY' ;
254 $rv .= $prefix . "|\n" ;
255 $rv .= $prefix . "+- $k" ;
256 $offset = ' ' x ($max + 4) ;
259 $rv .= $prefix . "$k" ;
260 $offset = ' ' x ($max + 1) ;
263 my ($ver, $rest) = @{ $v } ;
266 my $bar = @keys ? "|" : " ";
267 $rv .= " -" . "-" x ($max - length $k ) . "+\n" ;
268 $rv .= warningsTree ($rest, $prefix . $bar . $offset )
277 ###########################################################################
281 my ($f, $max, @bits) = @_ ;
282 my $mask = "\x00" x $max ;
286 vec($mask, $_, 1) = 1 ;
289 foreach (unpack("C*", $mask)) {
291 $string .= '\x' . sprintf("%2.2x", $_)
294 $string .= '\\' . sprintf("%o", $_)
302 my($max, @bits) = @_;
303 return mkHexOct("x", $max, @bits);
308 my($max, @bits) = @_;
309 return mkHexOct("o", $max, @bits);
312 ###########################################################################
314 if (@ARGV && $ARGV[0] eq "tree")
316 print warningsTree($tree, " ") ;
320 my ($warn, $pm) = map {
321 open_new($_, '>', { by => 'regen/warnings.pl' });
322 } 'warnings.h', 'lib/warnings.pm';
324 my ($index, $warn_size);
327 # generate warnings.h
331 #define Perl_Warn_Off_(x) ((x) / 8)
332 #define Perl_Warn_Bit_(x) (1 << ((x) % 8))
333 #define PerlWarnIsSet_(a, x) ((a)[Perl_Warn_Off_(x)] & Perl_Warn_Bit_(x))
336 #define G_WARN_OFF 0 /* $^W == 0 */
337 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
338 #define G_WARN_ALL_ON 2 /* -W flag */
339 #define G_WARN_ALL_OFF 4 /* -X flag */
340 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
341 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
343 #define pWARN_STD NULL
344 #define pWARN_ALL (STRLEN *) &PL_WARN_ALL /* use warnings 'all' */
345 #define pWARN_NONE (STRLEN *) &PL_WARN_NONE /* no warnings 'all' */
347 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
350 /* if PL_warnhook is set to this value, then warnings die */
351 #define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
357 $index = orderValues();
359 die <<EOM if $index > 255 ;
360 Too many warnings categories -- max is 255
361 rewrite packWARN* & unpackWARN* macros
365 for (my $i = $index; $i & 3; $i++) {
366 push @{$list{all}}, $i;
370 $warn_size = int($index / 8) + ($index % 8 != 0) ;
375 foreach $k (sort { $a <=> $b } keys %ValueToName) {
376 my ($name, $version) = @{ $ValueToName{$k} };
377 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
378 if $last_ver != $version ;
380 $name = "WARN_$name";
381 print $warn tab(6, "#define $name"), " $k\n" ;
383 $last_ver = $version ;
386 print $warn tab(6, '#define WARNsize'), " $warn_size\n" ;
387 print $warn tab(6, '#define WARN_ALLstring'), ' "', ('\125' x $warn_size) , "\"\n" ;
388 print $warn tab(6, '#define WARN_NONEstring'), ' "', ('\0' x $warn_size) , "\"\n" ;
392 #define isLEXWARN_on \
393 cBOOL(PL_curcop && PL_curcop->cop_warnings != pWARN_STD)
394 #define isLEXWARN_off \
395 cBOOL(!PL_curcop || PL_curcop->cop_warnings == pWARN_STD)
396 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
397 #define isWARN_on(c,x) (PerlWarnIsSet_((U8 *)(c + 1), 2*(x)))
398 #define isWARNf_on(c,x) (PerlWarnIsSet_((U8 *)(c + 1), 2*(x)+1))
400 #define DUP_WARNINGS(p) Perl_dup_warnings(aTHX_ p)
402 #define free_and_set_cop_warnings(cmp,w) STMT_START { \
403 if (!specialWARN((cmp)->cop_warnings)) PerlMemShared_free((cmp)->cop_warnings); \
404 (cmp)->cop_warnings = w; \
409 =head1 Warning and Dieing
411 In all these calls, the C<U32 wI<n>> parameters are warning category
412 constants. You can see the ones currently available in
413 L<warnings/Category Hierarchy>, just capitalize all letters in the names
414 and prefix them by C<WARN_>. So, for example, the category C<void> used in a
415 perl program becomes C<WARN_VOID> when used in XS code and passed to one of
418 =for apidoc Am|bool|ckWARN|U32 w
419 =for apidoc_item ||ckWARN2|U32 w1|U32 w2
420 =for apidoc_item ||ckWARN3|U32 w1|U32 w2|U32 w3
421 =for apidoc_item ||ckWARN4|U32 w1|U32 w2|U32 w3|U32 w4
422 These return a boolean as to whether or not warnings are enabled for any of
423 the warning category(ies) parameters: C<w>, C<w1>, ....
425 Should any of the categories by default be enabled even if not within the
426 scope of S<C<use warnings>>, instead use the C<L</ckWARN_d>> macros.
428 The categories must be completely independent, one may not be subclassed from
431 =for apidoc Am|bool|ckWARN_d|U32 w
432 =for apidoc_item ||ckWARN2_d|U32 w1|U32 w2
433 =for apidoc_item ||ckWARN3_d|U32 w1|U32 w2|U32 w3
434 =for apidoc_item ||ckWARN4_d|U32 w1|U32 w2|U32 w3|U32 w4
436 Like C<L</ckWARN>>, but for use if and only if the warning category(ies) is by
437 default enabled even if not within the scope of S<C<use warnings>>.
439 =for apidoc Am|U32|packWARN|U32 w1
440 =for apidoc_item ||packWARN2|U32 w1|U32 w2
441 =for apidoc_item ||packWARN3|U32 w1|U32 w2|U32 w3
442 =for apidoc_item ||packWARN4|U32 w1|U32 w2|U32 w3|U32 w4
444 These macros are used to pack warning categories into a single U32 to pass to
445 macros and functions that take a warning category parameter. The number of
446 categories to pack is given by the name, with a corresponding number of
447 category parameters passed.
453 #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
455 /* The w1, w2 ... should be independent warnings categories; one shouldn't be
456 * a subcategory of any other */
458 #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
459 #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
460 #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
462 #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
463 #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
464 #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
465 #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
469 #define packWARN(a) (a )
471 /* The a, b, ... should be independent warnings categories; one shouldn't be
472 * a subcategory of any other */
474 #define packWARN2(a,b) ((a) | ((b)<<8) )
475 #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
476 #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
478 #define unpackWARN1(x) ((U8) (x) )
479 #define unpackWARN2(x) ((U8) ((x) >> 8))
480 #define unpackWARN3(x) ((U8) ((x) >> 16))
481 #define unpackWARN4(x) ((U8) ((x) >> 24))
485 !specialWARN(PL_curcop->cop_warnings) && \
486 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
488 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
490 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
492 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))))))))
496 print $warn "\n\n/*\n" ;
497 print $warn map { "=for apidoc Amnh||$_\n" } @names;
498 print $warn "\n=cut\n*/\n\n" ;
499 print $warn "/* end of file warnings.h */\n";
501 read_only_bottom_close_and_rename($warn);
505 last if /^VERSION$/ ;
509 print $pm qq(our \$VERSION = "$::VERSION";\n);
512 last if /^KEYWORDS$/ ;
517 print $pm "our %Offsets = (" ;
518 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
519 my ($name, $version) = @{ $ValueToName{$k} };
522 if ( $last_ver != $version ) {
524 print $pm tab(6, " # Warnings Categories added in Perl $version");
527 print $pm tab(6, " '$name'"), "=> $k,\n" ;
528 $last_ver = $version;
533 print $pm "our %Bits = (\n" ;
534 foreach my $k (sort keys %list) {
537 my @list = sort { $a <=> $b } @$v ;
539 print $pm tab(6, " '$k'"), '=> "',
540 mkHex($warn_size, map $_ * 2 , @list),
541 '", # [', mkRange(@list), "]\n" ;
546 print $pm "our %DeadBits = (\n" ;
547 foreach my $k (sort keys %list) {
550 my @list = sort { $a <=> $b } @$v ;
552 print $pm tab(6, " '$k'"), '=> "',
553 mkHex($warn_size, map $_ * 2 + 1 , @list),
554 '", # [', mkRange(@list), "]\n" ;
558 print $pm "# These are used by various things, including our own tests\n";
559 print $pm tab(6, 'our $NONE'), '= "', ('\0' x $warn_size) , "\";\n" ;
560 print $pm tab(6, 'our $DEFAULT'), '= "', mkHex($warn_size, map $_ * 2, @def),
561 '"; # [', mkRange(sort { $a <=> $b } @def), "]\n" ;
562 print $pm tab(6, 'our $LAST_BIT'), '= ' . "$index ;\n" ;
563 print $pm tab(6, 'our $BYTES'), '= ' . "$warn_size ;\n" ;
565 if ($_ eq "=for warnings.pl tree-goes-here\n") {
566 print $pm warningsTree($tree, " ");
572 read_only_bottom_close_and_rename($pm);
579 # Verify that we're called correctly so that warnings will work.
580 # Can't use Carp, since Carp uses us!
581 # String regexps because constant folding = smaller optree = less memory vs regexp literal
582 # see also strict.pm.
583 die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2]
584 if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' )
585 && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' );
591 require Carp; # this initializes %CarpInternal
592 local $Carp::CarpInternal{'warnings'};
593 delete $Carp::CarpInternal{'warnings'};
599 my $want_len = ($LAST_BIT + 7) >> 3;
600 my $len = length($bits);
601 if ($len != $want_len) {
603 $bits = "\x00" x $want_len;
604 } elsif ($len > $want_len) {
605 substr $bits, $want_len, $len-$want_len, "";
607 my $x = vec($bits, $Offsets{all} >> 1, 2);
610 $bits .= chr($x) x ($want_len - $len);
622 $mask = _expand_bits($mask);
623 foreach my $word ( @_ ) {
624 if ($word eq 'FATAL') {
628 elsif ($word eq 'NONFATAL') {
632 elsif ($catmask = $Bits{$word}) {
634 $mask |= $DeadBits{$word} if $fatal ;
635 $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ;
638 { Croaker("Unknown warnings category '$word'")}
646 # called from B::Deparse.pm
647 push @_, 'all' unless @_ ;
648 return _bits("", @_) ;
653 my $invocant = shift;
655 # append 'all' when implied (empty import list or after a lone
656 # "FATAL" or "NONFATAL")
658 if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL'));
661 foreach my $warning (@_) {
662 if($warning =~ /^(NON)?FATAL$/) {
664 } elsif(substr($warning, 0, 1) ne '-') {
665 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
666 ${^WARNING_BITS} = _bits($mask, @fatal, $warning);
668 $invocant->unimport(substr($warning, 1));
678 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
680 # append 'all' when implied (empty import list or after a lone "FATAL")
681 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
683 $mask = _expand_bits($mask);
684 foreach my $word ( @_ ) {
685 if ($word eq 'FATAL') {
688 elsif ($catmask = $Bits{$word}) {
689 $mask = ~(~$mask | $catmask | $DeadBits{$word});
692 { Croaker("Unknown warnings category '$word'")}
695 ${^WARNING_BITS} = $mask ;
698 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
701 sub MESSAGE () { 4 };
711 my $has_message = $wanted & MESSAGE;
712 my $has_level = $wanted & LEVEL ;
715 if (@_ != ($has_message ? 3 : 2)) {
716 my $sub = (caller 1)[3];
717 my $syntax = $has_message
718 ? "category, level, 'message'"
720 Croaker("Usage: $sub($syntax)");
723 elsif (not @_ == 1 || @_ == ($has_message ? 2 : 0)) {
724 my $sub = (caller 1)[3];
725 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
726 Croaker("Usage: $sub($syntax)");
729 my $message = pop if $has_message;
732 # check the category supplied.
734 if (my $type = ref $category) {
735 Croaker("not an object")
736 if exists $builtin_type{$type};
740 $offset = $Offsets{$category};
741 Croaker("Unknown warnings category '$category'")
742 unless defined $offset;
745 $category = (caller(1))[0] ;
746 $offset = $Offsets{$category};
747 Croaker("package '$category' not registered for warnings")
748 unless defined $offset ;
756 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
757 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
765 $i = _error_loc(); # see where Carp will allocate the error
768 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
769 # explicitly returns undef.
770 my(@callers_bitmask) = (caller($i))[9] ;
771 my $callers_bitmask =
772 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
773 length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all};
776 foreach my $type (FATAL, NORMAL) {
777 next unless $wanted & $type;
779 push @results, vec($callers_bitmask, $offset + $type - 1, 1);
782 # &enabled and &fatal_enabled
783 return $results[0] unless $has_message;
785 # &warnif, and the category is neither enabled as warning nor as fatal
786 return if ($wanted & (NORMAL | FATAL | MESSAGE))
787 == (NORMAL | FATAL | MESSAGE)
788 && !($results[0] || $results[1]);
790 # If we have an explicit level, bypass Carp.
791 if ($has_level and @callers_bitmask) {
792 # logic copied from util.c:mess_sv
793 my $stuff = " at " . join " line ", (caller $i)[1,2];
794 $stuff .= sprintf ", <%s> %s %d",
796 ($/ eq "\n" ? "line" : "chunk"), $.
797 if $. && ${^LAST_FH};
798 die "$message$stuff.\n" if $results[0];
799 return warn "$message$stuff.\n";
803 Carp::croak($message) if $results[0];
804 # will always get here for &warn. will only get here for &warnif if the
805 # category is enabled
806 Carp::carp($message);
814 vec($mask, $bit, 1) = 1;
818 sub register_categories
822 for my $name (@names) {
823 if (! defined $Bits{$name}) {
824 $Offsets{$name} = $LAST_BIT;
825 $Bits{$name} = _mkMask($LAST_BIT++);
826 $DeadBits{$name} = _mkMask($LAST_BIT++);
827 if (length($Bits{$name}) > length($Bits{all})) {
828 $Bits{all} .= "\x55";
829 $DeadBits{all} .= "\xaa";
837 goto &Carp::short_error_loc; # don't introduce another stack frame
842 return __chk(NORMAL, @_);
847 return __chk(FATAL, @_);
852 return __chk(FATAL | MESSAGE, @_);
857 return __chk(NORMAL | FATAL | MESSAGE, @_);
862 return __chk(NORMAL | LEVEL, @_);
865 sub fatal_enabled_at_level
867 return __chk(FATAL | LEVEL, @_);
872 return __chk(FATAL | MESSAGE | LEVEL, @_);
877 return __chk(NORMAL | FATAL | MESSAGE | LEVEL, @_);
880 # These are not part of any public interface, so we can delete them to save
882 delete @warnings::{qw(NORMAL FATAL MESSAGE LEVEL)};
889 warnings - Perl pragma to control optional warnings
896 # Standard warnings are enabled by use v5.35 or above
900 no warnings "uninitialized";
902 # or equivalent to those last two ...
903 use warnings qw(all -uninitialized);
905 use warnings::register;
906 if (warnings::enabled()) {
907 warnings::warn("some warning");
910 if (warnings::enabled("void")) {
911 warnings::warn("void", "some warning");
914 if (warnings::enabled($object)) {
915 warnings::warn($object, "some warning");
918 warnings::warnif("some warning");
919 warnings::warnif("void", "some warning");
920 warnings::warnif($object, "some warning");
924 The C<warnings> pragma gives control over which warnings are enabled in
925 which parts of a Perl program. It's a more flexible alternative for
926 both the command line flag B<-w> and the equivalent Perl variable,
929 This pragma works just like the C<strict> pragma.
930 This means that the scope of the warning pragma is limited to the
931 enclosing block. It also means that the pragma setting will not
932 leak across files (via C<use>, C<require> or C<do>). This allows
933 authors to independently define the degree of warning checks that will
934 be applied to their module.
936 By default, optional warnings are disabled, so any legacy code that
937 doesn't attempt to control the warnings will work unchanged.
939 All warnings are enabled in a block by either of these:
944 Similarly all warnings are disabled in a block by either of these:
949 For example, consider the code below:
959 The code in the enclosing block has warnings enabled, but the inner
960 block has them disabled. In this case that means the assignment to the
961 scalar C<$z> will trip the C<"Scalar value @x[0] better written as $x[0]">
962 warning, but the assignment to the scalar C<$y> will not.
964 All warnings are enabled automatically within the scope of
965 a C<L<use v5.35|perlfunc/use VERSION>> (or higher) declaration.
967 =head2 Default Warnings and Optional Warnings
969 Before the introduction of lexical warnings, Perl had two classes of
970 warnings: mandatory and optional.
972 As its name suggests, if your code tripped a mandatory warning, you
973 would get a warning whether you wanted it or not.
974 For example, the code below would always produce an C<"isn't numeric">
975 warning about the "2:".
979 With the introduction of lexical warnings, mandatory warnings now become
980 I<default> warnings. The difference is that although the previously
981 mandatory warnings are still enabled by default, they can then be
982 subsequently enabled or disabled with the lexical warning pragma. For
983 example, in the code below, an C<"isn't numeric"> warning will only
984 be reported for the C<$x> variable.
990 Note that neither the B<-w> flag or the C<$^W> can be used to
991 disable/enable default warnings. They are still mandatory in this case.
993 =head2 "Negative warnings"
995 As a convenience, you can (as of Perl 5.34) pass arguments to the
996 C<import()> method both positively and negatively. Negative warnings
997 are those with a C<-> sign prepended to their names; positive warnings
998 are anything else. This lets you turn on some warnings and turn off
999 others in one command. So, assuming that you've already turned on a
1000 bunch of warnings but want to tweak them a bit in some block, you can
1004 use warnings qw(uninitialized -redefine);
1008 which is equivalent to:
1011 use warnings qw(uninitialized);
1012 no warnings qw(redefine);
1016 The argument list is processed in the order you specify. So, for example, if you
1017 don't want to be warned about use of experimental features, except for C<somefeature>
1018 that you really dislike, you can say this:
1020 use warnings qw(all -experimental experimental::somefeature);
1022 which is equivalent to:
1025 no warnings 'experimental';
1026 use warnings 'experimental::somefeature';
1028 =head2 What's wrong with B<-w> and C<$^W>
1030 Although very useful, the big problem with using B<-w> on the command
1031 line to enable warnings is that it is all or nothing. Take the typical
1032 scenario when you are writing a Perl program. Parts of the code you
1033 will write yourself, but it's very likely that you will make use of
1034 pre-written Perl modules. If you use the B<-w> flag in this case, you
1035 end up enabling warnings in pieces of code that you haven't written.
1037 Similarly, using C<$^W> to either disable or enable blocks of code is
1038 fundamentally flawed. For a start, say you want to disable warnings in
1039 a block of code. You might expect this to be enough to do the trick:
1047 When this code is run with the B<-w> flag, a warning will be produced
1048 for the C<$x> line: C<"Reversed += operator">.
1050 The problem is that Perl has both compile-time and run-time warnings. To
1051 disable compile-time warnings you need to rewrite the code like this:
1059 And note that unlike the first example, this will permanently set C<$^W>
1060 since it cannot both run during compile-time and be localized to a
1063 The other big problem with C<$^W> is the way you can inadvertently
1064 change the warning setting in unexpected places in your code. For example,
1065 when the code below is run (without the B<-w> flag), the second call
1066 to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
1081 This is a side-effect of C<$^W> being dynamically scoped.
1083 Lexical warnings get around these limitations by allowing finer control
1084 over where warnings can or can't be tripped.
1086 =head2 Controlling Warnings from the Command Line
1088 There are three Command Line flags that can be used to control when
1089 warnings are (or aren't) produced:
1096 This is the existing flag. If the lexical warnings pragma is B<not>
1097 used in any of your code, or any of the modules that you use, this flag
1098 will enable warnings everywhere. See L</Backward Compatibility> for
1099 details of how this flag interacts with lexical warnings.
1104 If the B<-W> flag is used on the command line, it will enable all warnings
1105 throughout the program regardless of whether warnings were disabled
1106 locally using C<no warnings> or C<$^W =0>.
1107 This includes all files that get
1108 included via C<use>, C<require> or C<do>.
1109 Think of it as the Perl equivalent of the "lint" command.
1114 Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
1118 =head2 Backward Compatibility
1120 If you are used to working with a version of Perl prior to the
1121 introduction of lexically scoped warnings, or have code that uses both
1122 lexical warnings and C<$^W>, this section will describe how they interact.
1124 How Lexical Warnings interact with B<-w>/C<$^W>:
1130 If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
1131 control warnings is used and neither C<$^W> nor the C<warnings> pragma
1132 are used, then default warnings will be enabled and optional warnings
1134 This means that legacy code that doesn't attempt to control the warnings
1135 will work unchanged.
1139 The B<-w> flag just sets the global C<$^W> variable as in 5.005. This
1140 means that any legacy code that currently relies on manipulating C<$^W>
1141 to control warning behavior will still work as is.
1145 Apart from now being a boolean, the C<$^W> variable operates in exactly
1146 the same horrible uncontrolled global way, except that it cannot
1147 disable/enable default warnings.
1151 If a piece of code is under the control of the C<warnings> pragma,
1152 both the C<$^W> variable and the B<-w> flag will be ignored for the
1153 scope of the lexical warning.
1157 The only way to override a lexical warnings setting is with the B<-W>
1158 or B<-X> command line flags.
1162 The combined effect of 3 & 4 is that it will allow code which uses
1163 the C<warnings> pragma to control the warning behavior of $^W-type
1164 code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
1166 =head2 Category Hierarchy
1167 X<warning, categories>
1169 A hierarchy of "categories" have been defined to allow groups of warnings
1170 to be enabled/disabled in isolation.
1172 The current hierarchy is:
1174 =for warnings.pl tree-goes-here
1176 Just like the "strict" pragma any of these categories can be combined
1178 use warnings qw(void redefine);
1179 no warnings qw(io syntax untie);
1181 Also like the "strict" pragma, if there is more than one instance of the
1182 C<warnings> pragma in a given scope the cumulative effect is additive.
1184 use warnings qw(void); # only "void" warnings enabled
1186 use warnings qw(io); # only "void" & "io" warnings enabled
1188 no warnings qw(void); # only "io" warnings enabled
1190 To determine which category a specific warning has been assigned to see
1193 Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
1194 sub-category of the "syntax" category. It is now a top-level category
1197 Note: Before 5.21.0, the "missing" lexical warnings category was
1198 internally defined to be the same as the "uninitialized" category. It
1199 is now a top-level category in its own right.
1201 =head2 Fatal Warnings
1204 The presence of the word "FATAL" in the category list will escalate
1205 warnings in those categories into fatal errors in that lexical scope.
1207 B<NOTE:> FATAL warnings should be used with care, particularly
1208 C<< FATAL => 'all' >>.
1210 Libraries using L<warnings::warn|/FUNCTIONS> for custom warning categories
1211 generally don't expect L<warnings::warn|/FUNCTIONS> to be fatal and can wind up
1212 in an unexpected state as a result. For XS modules issuing categorized
1213 warnings, such unanticipated exceptions could also expose memory leak bugs.
1215 Moreover, the Perl interpreter itself has had serious bugs involving
1216 fatalized warnings. For a summary of resolved and unresolved problems as
1217 of January 2015, please see
1218 L<this perl5-porters post|http://www.nntp.perl.org/group/perl.perl5.porters/2015/01/msg225235.html>.
1220 While some developers find fatalizing some warnings to be a useful
1221 defensive programming technique, using C<< FATAL => 'all' >> to fatalize
1222 all possible warning categories -- including custom ones -- is particularly
1223 risky. Therefore, the use of C<< FATAL => 'all' >> is
1224 L<discouraged|perlpolicy/discouraged>.
1226 The L<strictures|strictures/VERSION-2> module on CPAN offers one example of
1227 a warnings subset that the module's authors believe is relatively safe to
1230 B<NOTE:> Users of FATAL warnings, especially those using
1231 C<< FATAL => 'all' >>, should be fully aware that they are risking future
1232 portability of their programs by doing so. Perl makes absolutely no
1233 commitments to not introduce new warnings or warnings categories in the
1234 future; indeed, we explicitly reserve the right to do so. Code that may
1235 not warn now may warn in a future release of Perl if the Perl5 development
1236 team deems it in the best interests of the community to do so. Should code
1237 using FATAL warnings break due to the introduction of a new warning we will
1238 NOT consider it an incompatible change. Users of FATAL warnings should
1239 take special caution during upgrades to check to see if their code triggers
1240 any new warnings and should pay particular attention to the fine print of
1241 the documentation of the features they use to ensure they do not exploit
1242 features that are documented as risky, deprecated, or unspecified, or where
1243 the documentation says "so don't do that", or anything with the same sense
1244 and spirit. Use of such features in combination with FATAL warnings is
1245 ENTIRELY AT THE USER'S RISK.
1247 The following documentation describes how to use FATAL warnings but the
1248 perl5 porters strongly recommend that you understand the risks before doing
1249 so, especially for library code intended for use by others, as there is no
1250 way for downstream users to change the choice of fatal categories.
1252 In the code below, the use of C<time>, C<length>
1253 and C<join> can all produce a C<"Useless use of xxx in void context">
1261 use warnings FATAL => qw(void);
1269 When run it produces this output
1271 Useless use of time in void context at fatal line 3.
1272 Useless use of length in void context at fatal line 7.
1274 The scope where C<length> is used has escalated the C<void> warnings
1275 category into a fatal error, so the program terminates immediately when it
1276 encounters the warning.
1278 To explicitly turn off a "FATAL" warning you just disable the warning
1279 it is associated with. So, for example, to disable the "void" warning
1280 in the example above, either of these will do the trick:
1282 no warnings qw(void);
1283 no warnings FATAL => qw(void);
1285 If you want to downgrade a warning that has been escalated into a fatal
1286 error back to a normal warning, you can use the "NONFATAL" keyword. For
1287 example, the code below will promote all warnings into fatal errors,
1288 except for those in the "syntax" category.
1290 use warnings FATAL => 'all', NONFATAL => 'syntax';
1292 As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
1295 use v5.20; # Perl 5.20 or greater is required for the following
1296 use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';"
1298 However, you should still heed the guidance earlier in this section against
1299 using C<< use warnings FATAL => 'all'; >>.
1301 If you want your program to be compatible with versions of Perl before
1302 5.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In
1303 previous versions of Perl, the behavior of the statements
1304 C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
1305 C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
1306 they included the C<< => 'all' >> portion. As of 5.20, they do.)
1308 =head2 Reporting Warnings from a Module
1309 X<warning, reporting> X<warning, registering>
1311 The C<warnings> pragma provides a number of functions that are useful for
1312 module authors. These are used when you want to report a module-specific
1313 warning to a calling module has enabled warnings via the C<warnings>
1316 Consider the module C<MyMod::Abc> below.
1320 use warnings::register;
1324 if ($path !~ m#^/#) {
1325 warnings::warn("changing relative path to /var/abc")
1326 if warnings::enabled();
1327 $path = "/var/abc/$path";
1333 The call to C<warnings::register> will create a new warnings category
1334 called "MyMod::Abc", i.e. the new category name matches the current
1335 package name. The C<open> function in the module will display a warning
1336 message if it gets given a relative path as a parameter. This warnings
1337 will only be displayed if the code that uses C<MyMod::Abc> has actually
1338 enabled them with the C<warnings> pragma like below.
1341 use warnings 'MyMod::Abc';
1343 abc::open("../fred.txt");
1345 It is also possible to test whether the pre-defined warnings categories are
1346 set in the calling module with the C<warnings::enabled> function. Consider
1347 this snippet of code:
1352 if (warnings::enabled("deprecated")) {
1353 warnings::warn("deprecated",
1354 "open is deprecated, use new instead");
1363 The function C<open> has been deprecated, so code has been included to
1364 display a warning message whenever the calling module has (at least) the
1365 "deprecated" warnings category enabled. Something like this, say.
1367 use warnings 'deprecated';
1370 MyMod::Abc::open($filename);
1372 Either the C<warnings::warn> or C<warnings::warnif> function should be
1373 used to actually display the warnings message. This is because they can
1374 make use of the feature that allows warnings to be escalated into fatal
1375 errors. So in this case
1378 use warnings FATAL => 'MyMod::Abc';
1380 MyMod::Abc::open('../fred.txt');
1382 the C<warnings::warnif> function will detect this and die after
1383 displaying the warning message.
1385 The three warnings functions, C<warnings::warn>, C<warnings::warnif>
1386 and C<warnings::enabled> can optionally take an object reference in place
1387 of a category name. In this case the functions will use the class name
1388 of the object as the warnings category.
1390 Consider this example:
1395 use warnings::register;
1408 if ($value % 2 && warnings::enabled($self))
1409 { warnings::warn($self, "Odd numbers are unsafe") }
1416 $self->check($value);
1424 use warnings::register;
1426 our @ISA = qw( Original );
1436 The code below makes use of both modules, but it only enables warnings from
1441 use warnings 'Derived';
1442 my $x = Original->new();
1444 my $y = Derived->new();
1447 When this code is run only the C<Derived> object, C<$y>, will generate
1450 Odd numbers are unsafe at main.pl line 7
1452 Notice also that the warning is reported at the line where the object is first
1455 When registering new categories of warning, you can supply more names to
1456 warnings::register like this:
1459 use warnings::register qw(format precision);
1463 warnings::warnif('MyModule::format', '...');
1467 Note: The functions with names ending in C<_at_level> were added in Perl
1472 =item use warnings::register
1474 Creates a new warnings category with the same name as the package where
1475 the call to the pragma is used.
1477 =item warnings::enabled()
1479 Use the warnings category with the same name as the current package.
1481 Return TRUE if that warnings category is enabled in the calling module.
1482 Otherwise returns FALSE.
1484 =item warnings::enabled($category)
1486 Return TRUE if the warnings category, C<$category>, is enabled in the
1488 Otherwise returns FALSE.
1490 =item warnings::enabled($object)
1492 Use the name of the class for the object reference, C<$object>, as the
1495 Return TRUE if that warnings category is enabled in the first scope
1496 where the object is used.
1497 Otherwise returns FALSE.
1499 =item warnings::enabled_at_level($category, $level)
1501 Like C<warnings::enabled>, but $level specifies the exact call frame, 0
1502 being the immediate caller.
1504 =item warnings::fatal_enabled()
1506 Return TRUE if the warnings category with the same name as the current
1507 package has been set to FATAL in the calling module.
1508 Otherwise returns FALSE.
1510 =item warnings::fatal_enabled($category)
1512 Return TRUE if the warnings category C<$category> has been set to FATAL in
1514 Otherwise returns FALSE.
1516 =item warnings::fatal_enabled($object)
1518 Use the name of the class for the object reference, C<$object>, as the
1521 Return TRUE if that warnings category has been set to FATAL in the first
1522 scope where the object is used.
1523 Otherwise returns FALSE.
1525 =item warnings::fatal_enabled_at_level($category, $level)
1527 Like C<warnings::fatal_enabled>, but $level specifies the exact call frame,
1528 0 being the immediate caller.
1530 =item warnings::warn($message)
1532 Print C<$message> to STDERR.
1534 Use the warnings category with the same name as the current package.
1536 If that warnings category has been set to "FATAL" in the calling module
1537 then die. Otherwise return.
1539 =item warnings::warn($category, $message)
1541 Print C<$message> to STDERR.
1543 If the warnings category, C<$category>, has been set to "FATAL" in the
1544 calling module then die. Otherwise return.
1546 =item warnings::warn($object, $message)
1548 Print C<$message> to STDERR.
1550 Use the name of the class for the object reference, C<$object>, as the
1553 If that warnings category has been set to "FATAL" in the scope where C<$object>
1554 is first used then die. Otherwise return.
1556 =item warnings::warn_at_level($category, $level, $message)
1558 Like C<warnings::warn>, but $level specifies the exact call frame,
1559 0 being the immediate caller.
1561 =item warnings::warnif($message)
1565 if (warnings::enabled())
1566 { warnings::warn($message) }
1568 =item warnings::warnif($category, $message)
1572 if (warnings::enabled($category))
1573 { warnings::warn($category, $message) }
1575 =item warnings::warnif($object, $message)
1579 if (warnings::enabled($object))
1580 { warnings::warn($object, $message) }
1582 =item warnings::warnif_at_level($category, $level, $message)
1584 Like C<warnings::warnif>, but $level specifies the exact call frame,
1585 0 being the immediate caller.
1587 =item warnings::register_categories(@names)
1589 This registers warning categories for the given names and is primarily for
1590 use by the warnings::register pragma.
1594 See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.