3 # Regenerate (overwriting only if changed):
9 # from information hardcoded into this script (the $tree hash), plus the
10 # template for warnings.pm in the DATA section. Only part of
11 # pod/perllexwarn.pod (the warnings category hierarchy) is generated,
12 # the other parts remaining untouched.
14 # When changing the number of warnings, t/op/caller.t should change to
15 # correspond with the value of $BYTES in lib/warnings.pm
17 # With an argument of 'tree', just dump the contents of $tree and exits.
18 # Also accepts the standard regen_lib -q and -v args.
20 # This script is normally invoked from regen.pl.
25 require 'regen/regen_lib.pl';
30 sub DEFAULT_ON () { 1 }
31 sub DEFAULT_OFF () { 2 }
37 'pipe' => [ 5.008, DEFAULT_OFF],
38 'unopened' => [ 5.008, DEFAULT_OFF],
39 'closed' => [ 5.008, DEFAULT_OFF],
40 'newline' => [ 5.008, DEFAULT_OFF],
41 'exec' => [ 5.008, DEFAULT_OFF],
42 'layer' => [ 5.008, DEFAULT_OFF],
43 'syscalls' => [ 5.019, DEFAULT_OFF],
45 'syntax' => [ 5.008, {
46 'ambiguous' => [ 5.008, DEFAULT_OFF],
47 'semicolon' => [ 5.008, DEFAULT_OFF],
48 'precedence' => [ 5.008, DEFAULT_OFF],
49 'bareword' => [ 5.008, DEFAULT_OFF],
50 'reserved' => [ 5.008, DEFAULT_OFF],
51 'digit' => [ 5.008, DEFAULT_OFF],
52 'parenthesis' => [ 5.008, DEFAULT_OFF],
53 'printf' => [ 5.008, DEFAULT_OFF],
54 'prototype' => [ 5.008, DEFAULT_OFF],
55 'qw' => [ 5.008, DEFAULT_OFF],
56 'illegalproto' => [ 5.011, DEFAULT_OFF],
58 'severe' => [ 5.008, {
59 'inplace' => [ 5.008, DEFAULT_ON],
60 'internal' => [ 5.008, DEFAULT_OFF],
61 'debugging' => [ 5.008, DEFAULT_ON],
62 'malloc' => [ 5.008, DEFAULT_ON],
64 'deprecated' => [ 5.008, DEFAULT_ON],
65 'void' => [ 5.008, DEFAULT_OFF],
66 'recursion' => [ 5.008, DEFAULT_OFF],
67 'redefine' => [ 5.008, DEFAULT_OFF],
68 'numeric' => [ 5.008, DEFAULT_OFF],
69 'uninitialized' => [ 5.008, DEFAULT_OFF],
70 'once' => [ 5.008, DEFAULT_OFF],
71 'misc' => [ 5.008, DEFAULT_OFF],
72 'regexp' => [ 5.008, DEFAULT_OFF],
73 'glob' => [ 5.008, DEFAULT_ON],
74 'untie' => [ 5.008, DEFAULT_OFF],
75 'substr' => [ 5.008, DEFAULT_OFF],
76 'taint' => [ 5.008, DEFAULT_OFF],
77 'signal' => [ 5.008, DEFAULT_OFF],
78 'closure' => [ 5.008, DEFAULT_OFF],
79 'overflow' => [ 5.008, DEFAULT_OFF],
80 'portable' => [ 5.008, DEFAULT_OFF],
82 'surrogate' => [ 5.013, DEFAULT_OFF],
83 'nonchar' => [ 5.013, DEFAULT_OFF],
84 'non_unicode' => [ 5.013, DEFAULT_OFF],
86 'exiting' => [ 5.008, DEFAULT_OFF],
87 'pack' => [ 5.008, DEFAULT_OFF],
88 'unpack' => [ 5.008, DEFAULT_OFF],
89 'threads' => [ 5.008, DEFAULT_OFF],
90 'imprecision' => [ 5.011, DEFAULT_OFF],
91 'experimental' => [ 5.017, {
92 'experimental::lexical_subs' =>
93 [ 5.017, DEFAULT_ON ],
94 'experimental::regex_sets' =>
95 [ 5.017, DEFAULT_ON ],
96 'experimental::lexical_topic' =>
97 [ 5.017, DEFAULT_ON ],
98 'experimental::smartmatch' =>
99 [ 5.017, DEFAULT_ON ],
100 'experimental::postderef' =>
101 [ 5.019, DEFAULT_ON ],
102 'experimental::autoderef' =>
103 [ 5.019, DEFAULT_ON ],
104 'experimental::signatures' =>
105 [ 5.019, DEFAULT_ON ],
108 #'default' => [ 5.008, DEFAULT_ON ],
126 foreach $k (sort keys %$tre) {
128 die "duplicate key $k\n" if defined $list{$k} ;
129 die "Value associated with key '$k' is not an ARRAY reference"
130 if !ref $v || ref $v ne 'ARRAY' ;
132 my ($ver, $rest) = @{ $v } ;
133 push @{ $v_list{$ver} }, $k;
136 { valueWalk ($rest) }
145 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
146 foreach my $name (@{ $v_list{$ver} } ) {
147 $ValueToName{ $index } = [ uc $name, $ver ] ;
148 $NameToValue{ uc $name } = $index ++ ;
155 ###########################################################################
163 foreach $k (sort keys %$tre) {
165 die "duplicate key $k\n" if defined $list{$k} ;
166 die "Can't find key '$k'"
167 if ! defined $NameToValue{uc $k} ;
168 push @{ $list{$k} }, $NameToValue{uc $k} ;
169 die "Value associated with key '$k' is not an ARRAY reference"
170 if !ref $v || ref $v ne 'ARRAY' ;
172 my ($ver, $rest) = @{ $v } ;
174 { push (@{ $list{$k} }, walk ($rest)) }
175 elsif ($rest == DEFAULT_ON)
176 { push @def, $NameToValue{uc $k} }
178 push @list, @{ $list{$k} } ;
184 ###########################################################################
191 for my $i (1 .. @a - 1) {
193 if $a[$i] == $a[$i - 1] + 1
194 && ($i >= @a - 1 || $a[$i] + 1 == $a[$i + 1] );
196 $out[-1] = $a[-1] if $out[-1] eq "..";
198 my $out = join(",",@out);
200 $out =~ s/,(\.\.,)+/../g ;
204 ###########################################################################
211 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
212 my @keys = sort keys %$tre ;
216 while ($k = shift @keys) {
218 die "Value associated with key '$k' is not an ARRAY reference"
219 if !ref $v || ref $v ne 'ARRAY' ;
223 $rv .= $prefix . "|\n" ;
224 $rv .= $prefix . "+- $k" ;
225 $offset = ' ' x ($max + 4) ;
228 $rv .= $prefix . "$k" ;
229 $offset = ' ' x ($max + 1) ;
232 my ($ver, $rest) = @{ $v } ;
235 my $bar = @keys ? "|" : " ";
236 $rv .= " -" . "-" x ($max - length $k ) . "+\n" ;
237 $rv .= warningsTree ($rest, $prefix . $bar . $offset )
246 ###########################################################################
250 my ($f, $max, @a) = @_ ;
251 my $mask = "\x00" x $max ;
255 vec($mask, $_, 1) = 1 ;
258 foreach (unpack("C*", $mask)) {
260 $string .= '\x' . sprintf("%2.2x", $_)
263 $string .= '\\' . sprintf("%o", $_)
272 return mkHexOct("x", $max, @a);
278 return mkHexOct("o", $max, @a);
281 ###########################################################################
283 if (@ARGV && $ARGV[0] eq "tree")
285 print warningsTree($tree, " ") ;
289 my ($warn, $pm) = map {
290 open_new($_, '>', { by => 'regen/warnings.pl' });
291 } 'warnings.h', 'lib/warnings.pm';
293 my ($index, $warn_size);
296 # generate warnings.h
300 #define Off(x) ((x) / 8)
301 #define Bit(x) (1 << ((x) % 8))
302 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
305 #define G_WARN_OFF 0 /* $^W == 0 */
306 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
307 #define G_WARN_ALL_ON 2 /* -W flag */
308 #define G_WARN_ALL_OFF 4 /* -X flag */
309 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
310 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
312 #define pWARN_STD NULL
313 #define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
314 #define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
316 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
319 /* if PL_warnhook is set to this value, then warnings die */
320 #define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
326 $index = orderValues();
328 die <<EOM if $index > 255 ;
329 Too many warnings categories -- max is 255
330 rewrite packWARN* & unpackWARN* macros
336 $warn_size = int($index / 8) + ($index % 8 != 0) ;
340 foreach $k (sort { $a <=> $b } keys %ValueToName) {
341 my ($name, $version) = @{ $ValueToName{$k} };
342 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
343 if $last_ver != $version ;
345 print $warn tab(5, "#define WARN_$name"), " $k\n" ;
346 $last_ver = $version ;
350 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
351 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
352 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
356 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
357 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
358 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
359 #define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
360 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
362 #define DUP_WARNINGS(p) \
363 (specialWARN(p) ? (STRLEN*)(p) \
364 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
367 #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
369 /* The w1, w2 ... should be independent warnings categories; one shouldn't be
370 * a subcategory of any other */
372 #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
373 #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
374 #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
376 #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
377 #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
378 #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
379 #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
383 #define packWARN(a) (a )
385 /* The a, b, ... should be independent warnings categories; one shouldn't be
386 * a subcategory of any other */
388 #define packWARN2(a,b) ((a) | ((b)<<8) )
389 #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
390 #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
392 #define unpackWARN1(x) ((x) & 0xFF)
393 #define unpackWARN2(x) (((x) >>8) & 0xFF)
394 #define unpackWARN3(x) (((x) >>16) & 0xFF)
395 #define unpackWARN4(x) (((x) >>24) & 0xFF)
398 ( ! specialWARN(PL_curcop->cop_warnings) && \
399 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
400 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
401 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
402 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
403 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
405 /* end of file warnings.h */
408 read_only_bottom_close_and_rename($warn);
412 last if /^KEYWORDS$/ ;
413 if ($_ eq "=for warnings.pl tree-goes-here\n") {
414 print $pm warningsTree($tree, " ");
421 print $pm "our %Offsets = (\n" ;
422 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
423 my ($name, $version) = @{ $ValueToName{$k} };
426 if ( $last_ver != $version ) {
428 print $pm tab(4, " # Warnings Categories added in Perl $version");
431 print $pm tab(4, " '$name'"), "=> $k,\n" ;
432 $last_ver = $version;
435 print $pm " );\n\n" ;
437 print $pm "our %Bits = (\n" ;
438 foreach my $k (sort keys %list) {
441 my @list = sort { $a <=> $b } @$v ;
443 print $pm tab(4, " '$k'"), '=> "',
444 mkHex($warn_size, map $_ * 2 , @list),
445 '", # [', mkRange(@list), "]\n" ;
448 print $pm " );\n\n" ;
450 print $pm "our %DeadBits = (\n" ;
451 foreach my $k (sort keys %list) {
454 my @list = sort { $a <=> $b } @$v ;
456 print $pm tab(4, " '$k'"), '=> "',
457 mkHex($warn_size, map $_ * 2 + 1 , @list),
458 '", # [', mkRange(@list), "]\n" ;
461 print $pm " );\n\n" ;
462 print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
463 print $pm '$DEFAULT = "', mkHex($warn_size, map $_ * 2, @def),
464 '", # [', mkRange(@def), "]\n" ;
465 print $pm '$LAST_BIT = ' . "$index ;\n" ;
466 print $pm '$BYTES = ' . "$warn_size ;\n" ;
471 read_only_bottom_close_and_rename($pm);
473 my $lexwarn = open_new 'pod/perllexwarn.pod', '>';
474 open my $oldlexwarn, "pod/perllexwarn.pod"
475 or die "$0 cannot open pod/perllexwarn.pod for reading: $!";
476 select +(select($lexwarn), do {
477 while(<$oldlexwarn>) {
479 last if /=for warnings.pl begin/;
482 print warningsTree($tree, " ") ;
484 while(<$oldlexwarn>) {
485 last if /=for warnings.pl end/;
487 do { print } while <$oldlexwarn>;
490 close_and_rename($lexwarn);
495 our $VERSION = '1.22';
497 # Verify that we're called correctly so that warnings will work.
498 # see also strict.pm.
499 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
500 my (undef, $f, $l) = caller;
501 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
506 warnings - Perl pragma to control optional warnings
516 use warnings::register;
517 if (warnings::enabled()) {
518 warnings::warn("some warning");
521 if (warnings::enabled("void")) {
522 warnings::warn("void", "some warning");
525 if (warnings::enabled($object)) {
526 warnings::warn($object, "some warning");
529 warnings::warnif("some warning");
530 warnings::warnif("void", "some warning");
531 warnings::warnif($object, "some warning");
535 The C<use warnings> pragma enables to control precisely what warnings are
536 to be enabled in which parts of a Perl program. It's a more flexible
537 alternative for both the command line flag B<-w> and the equivalent Perl
540 This pragma works just like the C<strict> pragma.
541 This means that the scope of the warning pragma is limited to the
542 enclosing block. It also means that the pragma setting will not
543 leak across files (via C<use>, C<require> or C<do>). This allows
544 authors to independently define the degree of warning checks that will
545 be applied to their module.
547 By default, optional warnings are disabled, so any legacy code that
548 doesn't attempt to control the warnings will work unchanged.
550 All warnings are enabled in a block by either of these:
555 Similarly all warnings are disabled in a block by either of these:
560 For example, consider the code below:
570 The code in the enclosing block has warnings enabled, but the inner
571 block has them disabled. In this case that means the assignment to the
572 scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]">
573 warning, but the assignment to the scalar C<$b> will not.
575 =head2 Default Warnings and Optional Warnings
577 Before the introduction of lexical warnings, Perl had two classes of
578 warnings: mandatory and optional.
580 As its name suggests, if your code tripped a mandatory warning, you
581 would get a warning whether you wanted it or not.
582 For example, the code below would always produce an C<"isn't numeric">
583 warning about the "2:".
587 With the introduction of lexical warnings, mandatory warnings now become
588 I<default> warnings. The difference is that although the previously
589 mandatory warnings are still enabled by default, they can then be
590 subsequently enabled or disabled with the lexical warning pragma. For
591 example, in the code below, an C<"isn't numeric"> warning will only
592 be reported for the C<$a> variable.
598 Note that neither the B<-w> flag or the C<$^W> can be used to
599 disable/enable default warnings. They are still mandatory in this case.
601 =head2 What's wrong with B<-w> and C<$^W>
603 Although very useful, the big problem with using B<-w> on the command
604 line to enable warnings is that it is all or nothing. Take the typical
605 scenario when you are writing a Perl program. Parts of the code you
606 will write yourself, but it's very likely that you will make use of
607 pre-written Perl modules. If you use the B<-w> flag in this case, you
608 end up enabling warnings in pieces of code that you haven't written.
610 Similarly, using C<$^W> to either disable or enable blocks of code is
611 fundamentally flawed. For a start, say you want to disable warnings in
612 a block of code. You might expect this to be enough to do the trick:
620 When this code is run with the B<-w> flag, a warning will be produced
621 for the C<$a> line: C<"Reversed += operator">.
623 The problem is that Perl has both compile-time and run-time warnings. To
624 disable compile-time warnings you need to rewrite the code like this:
632 The other big problem with C<$^W> is the way you can inadvertently
633 change the warning setting in unexpected places in your code. For example,
634 when the code below is run (without the B<-w> flag), the second call
635 to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
650 This is a side-effect of C<$^W> being dynamically scoped.
652 Lexical warnings get around these limitations by allowing finer control
653 over where warnings can or can't be tripped.
655 =head2 Controlling Warnings from the Command Line
657 There are three Command Line flags that can be used to control when
658 warnings are (or aren't) produced:
665 This is the existing flag. If the lexical warnings pragma is B<not>
666 used in any of you code, or any of the modules that you use, this flag
667 will enable warnings everywhere. See L<Backward Compatibility> for
668 details of how this flag interacts with lexical warnings.
673 If the B<-W> flag is used on the command line, it will enable all warnings
674 throughout the program regardless of whether warnings were disabled
675 locally using C<no warnings> or C<$^W =0>.
676 This includes all files that get
677 included via C<use>, C<require> or C<do>.
678 Think of it as the Perl equivalent of the "lint" command.
683 Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
687 =head2 Backward Compatibility
689 If you are used to working with a version of Perl prior to the
690 introduction of lexically scoped warnings, or have code that uses both
691 lexical warnings and C<$^W>, this section will describe how they interact.
693 How Lexical Warnings interact with B<-w>/C<$^W>:
699 If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
700 control warnings is used and neither C<$^W> nor the C<warnings> pragma
701 are used, then default warnings will be enabled and optional warnings
703 This means that legacy code that doesn't attempt to control the warnings
708 The B<-w> flag just sets the global C<$^W> variable as in 5.005. This
709 means that any legacy code that currently relies on manipulating C<$^W>
710 to control warning behavior will still work as is.
714 Apart from now being a boolean, the C<$^W> variable operates in exactly
715 the same horrible uncontrolled global way, except that it cannot
716 disable/enable default warnings.
720 If a piece of code is under the control of the C<warnings> pragma,
721 both the C<$^W> variable and the B<-w> flag will be ignored for the
722 scope of the lexical warning.
726 The only way to override a lexical warnings setting is with the B<-W>
727 or B<-X> command line flags.
731 The combined effect of 3 & 4 is that it will allow code which uses
732 the C<warnings> pragma to control the warning behavior of $^W-type
733 code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
735 =head2 Category Hierarchy
736 X<warning, categories>
738 A hierarchy of "categories" have been defined to allow groups of warnings
739 to be enabled/disabled in isolation.
741 The current hierarchy is:
743 =for warnings.pl tree-goes-here
745 Just like the "strict" pragma any of these categories can be combined
747 use warnings qw(void redefine);
748 no warnings qw(io syntax untie);
750 Also like the "strict" pragma, if there is more than one instance of the
751 C<warnings> pragma in a given scope the cumulative effect is additive.
753 use warnings qw(void); # only "void" warnings enabled
755 use warnings qw(io); # only "void" & "io" warnings enabled
757 no warnings qw(void); # only "io" warnings enabled
759 To determine which category a specific warning has been assigned to see
762 Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
763 sub-category of the "syntax" category. It is now a top-level category
766 =head2 Fatal Warnings
769 The presence of the word "FATAL" in the category list will escalate any
770 warnings detected from the categories specified in the lexical scope
771 into fatal errors. In the code below, the use of C<time>, C<length>
772 and C<join> can all produce a C<"Useless use of xxx in void context">
780 use warnings FATAL => qw(void);
788 When run it produces this output
790 Useless use of time in void context at fatal line 3.
791 Useless use of length in void context at fatal line 7.
793 The scope where C<length> is used has escalated the C<void> warnings
794 category into a fatal error, so the program terminates immediately when it
795 encounters the warning.
797 To explicitly turn off a "FATAL" warning you just disable the warning
798 it is associated with. So, for example, to disable the "void" warning
799 in the example above, either of these will do the trick:
801 no warnings qw(void);
802 no warnings FATAL => qw(void);
804 If you want to downgrade a warning that has been escalated into a fatal
805 error back to a normal warning, you can use the "NONFATAL" keyword. For
806 example, the code below will promote all warnings into fatal errors,
807 except for those in the "syntax" category.
809 use warnings FATAL => 'all', NONFATAL => 'syntax';
811 As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
814 use v5.20; # Perl 5.20 or greater is required for the following
815 use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';"
817 If you want your program to be compatible with versions of Perl before
818 5.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In
819 previous versions of Perl, the behavior of the statements
820 C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
821 C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
822 they included the C<< => 'all' >> portion. As of 5.20, they do.)
824 B<NOTE:> Users of FATAL warnings, especially
825 those using C<< FATAL => 'all' >>
826 should be fully aware that they are risking future portability of their
827 programs by doing so. Perl makes absolutely no commitments to not
828 introduce new warnings, or warnings categories in the future, and indeed
829 we explicitly reserve the right to do so. Code that may not warn now may
830 warn in a future release of Perl if the Perl5 development team deems it
831 in the best interests of the community to do so. Should code using FATAL
832 warnings break due to the introduction of a new warning we will NOT
833 consider it an incompatible change. Users of FATAL warnings should take
834 special caution during upgrades to check to see if their code triggers
835 any new warnings and should pay particular attention to the fine print of
836 the documentation of the features they use to ensure they do not exploit
837 features that are documented as risky, deprecated, or unspecified, or where
838 the documentation says "so don't do that", or anything with the same sense
839 and spirit. Use of such features in combination with FATAL warnings is
840 ENTIRELY AT THE USER'S RISK.
842 =head2 Reporting Warnings from a Module
843 X<warning, reporting> X<warning, registering>
845 The C<warnings> pragma provides a number of functions that are useful for
846 module authors. These are used when you want to report a module-specific
847 warning to a calling module has enabled warnings via the C<warnings>
850 Consider the module C<MyMod::Abc> below.
854 use warnings::register;
858 if ($path !~ m#^/#) {
859 warnings::warn("changing relative path to /var/abc")
860 if warnings::enabled();
861 $path = "/var/abc/$path";
867 The call to C<warnings::register> will create a new warnings category
868 called "MyMod::Abc", i.e. the new category name matches the current
869 package name. The C<open> function in the module will display a warning
870 message if it gets given a relative path as a parameter. This warnings
871 will only be displayed if the code that uses C<MyMod::Abc> has actually
872 enabled them with the C<warnings> pragma like below.
875 use warnings 'MyMod::Abc';
877 abc::open("../fred.txt");
879 It is also possible to test whether the pre-defined warnings categories are
880 set in the calling module with the C<warnings::enabled> function. Consider
881 this snippet of code:
886 warnings::warnif("deprecated",
887 "open is deprecated, use new instead");
895 The function C<open> has been deprecated, so code has been included to
896 display a warning message whenever the calling module has (at least) the
897 "deprecated" warnings category enabled. Something like this, say.
899 use warnings 'deprecated';
902 MyMod::Abc::open($filename);
904 Either the C<warnings::warn> or C<warnings::warnif> function should be
905 used to actually display the warnings message. This is because they can
906 make use of the feature that allows warnings to be escalated into fatal
907 errors. So in this case
910 use warnings FATAL => 'MyMod::Abc';
912 MyMod::Abc::open('../fred.txt');
914 the C<warnings::warnif> function will detect this and die after
915 displaying the warning message.
917 The three warnings functions, C<warnings::warn>, C<warnings::warnif>
918 and C<warnings::enabled> can optionally take an object reference in place
919 of a category name. In this case the functions will use the class name
920 of the object as the warnings category.
922 Consider this example:
927 use warnings::register;
940 if ($value % 2 && warnings::enabled($self))
941 { warnings::warn($self, "Odd numbers are unsafe") }
948 $self->check($value);
956 use warnings::register;
958 our @ISA = qw( Original );
968 The code below makes use of both modules, but it only enables warnings from
973 use warnings 'Derived';
974 my $a = Original->new();
976 my $b = Derived->new();
979 When this code is run only the C<Derived> object, C<$b>, will generate
982 Odd numbers are unsafe at main.pl line 7
984 Notice also that the warning is reported at the line where the object is first
987 When registering new categories of warning, you can supply more names to
988 warnings::register like this:
991 use warnings::register qw(format precision);
995 warnings::warnif('MyModule::format', '...');
1001 =item use warnings::register
1003 Creates a new warnings category with the same name as the package where
1004 the call to the pragma is used.
1006 =item warnings::enabled()
1008 Use the warnings category with the same name as the current package.
1010 Return TRUE if that warnings category is enabled in the calling module.
1011 Otherwise returns FALSE.
1013 =item warnings::enabled($category)
1015 Return TRUE if the warnings category, C<$category>, is enabled in the
1017 Otherwise returns FALSE.
1019 =item warnings::enabled($object)
1021 Use the name of the class for the object reference, C<$object>, as the
1024 Return TRUE if that warnings category is enabled in the first scope
1025 where the object is used.
1026 Otherwise returns FALSE.
1028 =item warnings::fatal_enabled()
1030 Return TRUE if the warnings category with the same name as the current
1031 package has been set to FATAL in the calling module.
1032 Otherwise returns FALSE.
1034 =item warnings::fatal_enabled($category)
1036 Return TRUE if the warnings category C<$category> has been set to FATAL in
1038 Otherwise returns FALSE.
1040 =item warnings::fatal_enabled($object)
1042 Use the name of the class for the object reference, C<$object>, as the
1045 Return TRUE if that warnings category has been set to FATAL in the first
1046 scope where the object is used.
1047 Otherwise returns FALSE.
1049 =item warnings::warn($message)
1051 Print C<$message> to STDERR.
1053 Use the warnings category with the same name as the current package.
1055 If that warnings category has been set to "FATAL" in the calling module
1056 then die. Otherwise return.
1058 =item warnings::warn($category, $message)
1060 Print C<$message> to STDERR.
1062 If the warnings category, C<$category>, has been set to "FATAL" in the
1063 calling module then die. Otherwise return.
1065 =item warnings::warn($object, $message)
1067 Print C<$message> to STDERR.
1069 Use the name of the class for the object reference, C<$object>, as the
1072 If that warnings category has been set to "FATAL" in the scope where C<$object>
1073 is first used then die. Otherwise return.
1076 =item warnings::warnif($message)
1080 if (warnings::enabled())
1081 { warnings::warn($message) }
1083 =item warnings::warnif($category, $message)
1087 if (warnings::enabled($category))
1088 { warnings::warn($category, $message) }
1090 =item warnings::warnif($object, $message)
1094 if (warnings::enabled($object))
1095 { warnings::warn($object, $message) }
1097 =item warnings::register_categories(@names)
1099 This registers warning categories for the given names and is primarily for
1100 use by the warnings::register pragma, for which see L<perllexwarn>.
1104 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
1110 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
1114 require Carp; # this initializes %CarpInternal
1115 local $Carp::CarpInternal{'warnings'};
1116 delete $Carp::CarpInternal{'warnings'};
1126 foreach my $word ( @_ ) {
1127 if ($word eq 'FATAL') {
1131 elsif ($word eq 'NONFATAL') {
1135 elsif ($catmask = $Bits{$word}) {
1137 $mask |= $DeadBits{$word} if $fatal ;
1138 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
1141 { Croaker("Unknown warnings category '$word'")}
1149 # called from B::Deparse.pm
1150 push @_, 'all' unless @_ ;
1151 return _bits(undef, @_) ;
1158 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
1160 if (vec($mask, $Offsets{'all'}, 1)) {
1161 $mask |= $Bits{'all'} ;
1162 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1165 # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
1166 push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
1168 # Empty @_ is equivalent to @_ = 'all' ;
1169 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
1177 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
1179 if (vec($mask, $Offsets{'all'}, 1)) {
1180 $mask |= $Bits{'all'} ;
1181 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1184 # append 'all' when implied (empty import list or after a lone "FATAL")
1185 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
1187 foreach my $word ( @_ ) {
1188 if ($word eq 'FATAL') {
1191 elsif ($catmask = $Bits{$word}) {
1192 $mask &= ~($catmask | $DeadBits{$word} | $All);
1195 { Croaker("Unknown warnings category '$word'")}
1198 ${^WARNING_BITS} = $mask ;
1201 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
1203 sub MESSAGE () { 4 };
1205 sub NORMAL () { 1 };
1213 my $has_message = $wanted & MESSAGE;
1215 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
1216 my $sub = (caller 1)[3];
1217 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
1218 Croaker("Usage: $sub($syntax)");
1221 my $message = pop if $has_message;
1224 # check the category supplied.
1226 if (my $type = ref $category) {
1227 Croaker("not an object")
1228 if exists $builtin_type{$type};
1232 $offset = $Offsets{$category};
1233 Croaker("Unknown warnings category '$category'")
1234 unless defined $offset;
1237 $category = (caller(1))[0] ;
1238 $offset = $Offsets{$category};
1239 Croaker("package '$category' not registered for warnings")
1240 unless defined $offset ;
1248 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
1249 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
1254 $i = _error_loc(); # see where Carp will allocate the error
1257 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
1258 # explicitly returns undef.
1259 my(@callers_bitmask) = (caller($i))[9] ;
1260 my $callers_bitmask =
1261 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
1264 foreach my $type (FATAL, NORMAL) {
1265 next unless $wanted & $type;
1267 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
1268 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
1271 # &enabled and &fatal_enabled
1272 return $results[0] unless $has_message;
1274 # &warnif, and the category is neither enabled as warning nor as fatal
1275 return if $wanted == (NORMAL | FATAL | MESSAGE)
1276 && !($results[0] || $results[1]);
1279 Carp::croak($message) if $results[0];
1280 # will always get here for &warn. will only get here for &warnif if the
1281 # category is enabled
1282 Carp::carp($message);
1290 vec($mask, $bit, 1) = 1;
1294 sub register_categories
1298 for my $name (@names) {
1299 if (! defined $Bits{$name}) {
1300 $Bits{$name} = _mkMask($LAST_BIT);
1301 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
1302 $Offsets{$name} = $LAST_BIT ++;
1303 foreach my $k (keys %Bits) {
1304 vec($Bits{$k}, $LAST_BIT, 1) = 0;
1306 $DeadBits{$name} = _mkMask($LAST_BIT);
1307 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
1314 goto &Carp::short_error_loc; # don't introduce another stack frame
1319 return __chk(NORMAL, @_);
1324 return __chk(FATAL, @_);
1329 return __chk(FATAL | MESSAGE, @_);
1334 return __chk(NORMAL | FATAL | MESSAGE, @_);
1337 # These are not part of any public interface, so we can delete them to save
1339 delete @warnings::{qw(NORMAL FATAL MESSAGE)};