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