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