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