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