This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
narrow the filename check in strict.pm/warnings.pm
[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 # Can't use Carp, since Carp uses us!
493 # String regexps because constant folding = smaller optree = less memory vs regexp literal
494 # see also strict.pm.
495 die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2]
496     if __FILE__ !~ ( '(?x) \b     '.__PACKAGE__.'  \.pmc? \z' )
497     && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' );
498
499 KEYWORDS
500
501 our $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
502
503 sub Croaker
504 {
505     require Carp; # this initializes %CarpInternal
506     local $Carp::CarpInternal{'warnings'};
507     delete $Carp::CarpInternal{'warnings'};
508     Carp::croak(@_);
509 }
510
511 sub _bits {
512     my $mask = shift ;
513     my $catmask ;
514     my $fatal = 0 ;
515     my $no_fatal = 0 ;
516
517     foreach my $word ( @_ ) {
518         if ($word eq 'FATAL') {
519             $fatal = 1;
520             $no_fatal = 0;
521         }
522         elsif ($word eq 'NONFATAL') {
523             $fatal = 0;
524             $no_fatal = 1;
525         }
526         elsif ($catmask = $Bits{$word}) {
527             $mask |= $catmask ;
528             $mask |= $DeadBits{$word} if $fatal ;
529             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
530         }
531         else
532           { Croaker("Unknown warnings category '$word'")}
533     }
534
535     return $mask ;
536 }
537
538 sub bits
539 {
540     # called from B::Deparse.pm
541     push @_, 'all' unless @_ ;
542     return _bits(undef, @_) ;
543 }
544
545 sub import
546 {
547     shift;
548
549     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
550
551     if (vec($mask, $Offsets{'all'}, 1)) {
552         $mask |= $Bits{'all'} ;
553         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
554     }
555
556     # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
557     push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
558
559     # Empty @_ is equivalent to @_ = 'all' ;
560     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
561 }
562
563 sub unimport
564 {
565     shift;
566
567     my $catmask ;
568     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
569
570     if (vec($mask, $Offsets{'all'}, 1)) {
571         $mask |= $Bits{'all'} ;
572         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
573     }
574
575     # append 'all' when implied (empty import list or after a lone "FATAL")
576     push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
577
578     foreach my $word ( @_ ) {
579         if ($word eq 'FATAL') {
580             next;
581         }
582         elsif ($catmask = $Bits{$word}) {
583             $mask &= ~($catmask | $DeadBits{$word} | $All);
584         }
585         else
586           { Croaker("Unknown warnings category '$word'")}
587     }
588
589     ${^WARNING_BITS} = $mask ;
590 }
591
592 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
593
594 sub MESSAGE () { 4 };
595 sub FATAL () { 2 };
596 sub NORMAL () { 1 };
597
598 sub __chk
599 {
600     my $category ;
601     my $offset ;
602     my $isobj = 0 ;
603     my $wanted = shift;
604     my $has_message = $wanted & MESSAGE;
605
606     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
607         my $sub = (caller 1)[3];
608         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
609         Croaker("Usage: $sub($syntax)");
610     }
611
612     my $message = pop if $has_message;
613
614     if (@_) {
615         # check the category supplied.
616         $category = shift ;
617         if (my $type = ref $category) {
618             Croaker("not an object")
619                 if exists $builtin_type{$type};
620             $category = $type;
621             $isobj = 1 ;
622         }
623         $offset = $Offsets{$category};
624         Croaker("Unknown warnings category '$category'")
625             unless defined $offset;
626     }
627     else {
628         $category = (caller(1))[0] ;
629         $offset = $Offsets{$category};
630         Croaker("package '$category' not registered for warnings")
631             unless defined $offset ;
632     }
633
634     my $i;
635
636     if ($isobj) {
637         my $pkg;
638         $i = 2;
639         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
640             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
641         }
642         $i -= 2 ;
643     }
644     else {
645         $i = _error_loc(); # see where Carp will allocate the error
646     }
647
648     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
649     # explicitly returns undef.
650     my(@callers_bitmask) = (caller($i))[9] ;
651     my $callers_bitmask =
652          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
653
654     my @results;
655     foreach my $type (FATAL, NORMAL) {
656         next unless $wanted & $type;
657
658         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
659                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
660     }
661
662     # &enabled and &fatal_enabled
663     return $results[0] unless $has_message;
664
665     # &warnif, and the category is neither enabled as warning nor as fatal
666     return if $wanted == (NORMAL | FATAL | MESSAGE)
667         && !($results[0] || $results[1]);
668
669     require Carp;
670     Carp::croak($message) if $results[0];
671     # will always get here for &warn. will only get here for &warnif if the
672     # category is enabled
673     Carp::carp($message);
674 }
675
676 sub _mkMask
677 {
678     my ($bit) = @_;
679     my $mask = "";
680
681     vec($mask, $bit, 1) = 1;
682     return $mask;
683 }
684
685 sub register_categories
686 {
687     my @names = @_;
688
689     for my $name (@names) {
690         if (! defined $Bits{$name}) {
691             $Bits{$name}     = _mkMask($LAST_BIT);
692             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
693             $Offsets{$name}  = $LAST_BIT ++;
694             foreach my $k (keys %Bits) {
695                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
696             }
697             $DeadBits{$name} = _mkMask($LAST_BIT);
698             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
699         }
700     }
701 }
702
703 sub _error_loc {
704     require Carp;
705     goto &Carp::short_error_loc; # don't introduce another stack frame
706 }
707
708 sub enabled
709 {
710     return __chk(NORMAL, @_);
711 }
712
713 sub fatal_enabled
714 {
715     return __chk(FATAL, @_);
716 }
717
718 sub warn
719 {
720     return __chk(FATAL | MESSAGE, @_);
721 }
722
723 sub warnif
724 {
725     return __chk(NORMAL | FATAL | MESSAGE, @_);
726 }
727
728 # These are not part of any public interface, so we can delete them to save
729 # space.
730 delete @warnings::{qw(NORMAL FATAL MESSAGE)};
731
732 1;
733 __END__
734 =head1 NAME
735
736 warnings - Perl pragma to control optional warnings
737
738 =head1 SYNOPSIS
739
740     use warnings;
741     no warnings;
742
743     use warnings "all";
744     no warnings "all";
745
746     use warnings::register;
747     if (warnings::enabled()) {
748         warnings::warn("some warning");
749     }
750
751     if (warnings::enabled("void")) {
752         warnings::warn("void", "some warning");
753     }
754
755     if (warnings::enabled($object)) {
756         warnings::warn($object, "some warning");
757     }
758
759     warnings::warnif("some warning");
760     warnings::warnif("void", "some warning");
761     warnings::warnif($object, "some warning");
762
763 =head1 DESCRIPTION
764
765 The C<warnings> pragma gives control over which warnings are enabled in
766 which parts of a Perl program.  It's a more flexible alternative for
767 both the command line flag B<-w> and the equivalent Perl variable,
768 C<$^W>.
769
770 This pragma works just like the C<strict> pragma.
771 This means that the scope of the warning pragma is limited to the
772 enclosing block.  It also means that the pragma setting will not
773 leak across files (via C<use>, C<require> or C<do>).  This allows
774 authors to independently define the degree of warning checks that will
775 be applied to their module.
776
777 By default, optional warnings are disabled, so any legacy code that
778 doesn't attempt to control the warnings will work unchanged.
779
780 All warnings are enabled in a block by either of these:
781
782     use warnings;
783     use warnings 'all';
784
785 Similarly all warnings are disabled in a block by either of these:
786
787     no warnings;
788     no warnings 'all';
789
790 For example, consider the code below:
791
792     use warnings;
793     my @a;
794     {
795         no warnings;
796         my $b = @a[0];
797     }
798     my $c = @a[0];
799
800 The code in the enclosing block has warnings enabled, but the inner
801 block has them disabled.  In this case that means the assignment to the
802 scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]">
803 warning, but the assignment to the scalar C<$b> will not.
804
805 =head2 Default Warnings and Optional Warnings
806
807 Before the introduction of lexical warnings, Perl had two classes of
808 warnings: mandatory and optional.
809
810 As its name suggests, if your code tripped a mandatory warning, you
811 would get a warning whether you wanted it or not.
812 For example, the code below would always produce an C<"isn't numeric">
813 warning about the "2:".
814
815     my $a = "2:" + 3;
816
817 With the introduction of lexical warnings, mandatory warnings now become
818 I<default> warnings.  The difference is that although the previously
819 mandatory warnings are still enabled by default, they can then be
820 subsequently enabled or disabled with the lexical warning pragma.  For
821 example, in the code below, an C<"isn't numeric"> warning will only
822 be reported for the C<$a> variable.
823
824     my $a = "2:" + 3;
825     no warnings;
826     my $b = "2:" + 3;
827
828 Note that neither the B<-w> flag or the C<$^W> can be used to
829 disable/enable default warnings.  They are still mandatory in this case.
830
831 =head2 What's wrong with B<-w> and C<$^W>
832
833 Although very useful, the big problem with using B<-w> on the command
834 line to enable warnings is that it is all or nothing.  Take the typical
835 scenario when you are writing a Perl program.  Parts of the code you
836 will write yourself, but it's very likely that you will make use of
837 pre-written Perl modules.  If you use the B<-w> flag in this case, you
838 end up enabling warnings in pieces of code that you haven't written.
839
840 Similarly, using C<$^W> to either disable or enable blocks of code is
841 fundamentally flawed.  For a start, say you want to disable warnings in
842 a block of code.  You might expect this to be enough to do the trick:
843
844      {
845          local ($^W) = 0;
846          my $a =+ 2;
847          my $b; chop $b;
848      }
849
850 When this code is run with the B<-w> flag, a warning will be produced
851 for the C<$a> line:  C<"Reversed += operator">.
852
853 The problem is that Perl has both compile-time and run-time warnings.  To
854 disable compile-time warnings you need to rewrite the code like this:
855
856      {
857          BEGIN { $^W = 0 }
858          my $a =+ 2;
859          my $b; chop $b;
860      }
861
862 The other big problem with C<$^W> is the way you can inadvertently
863 change the warning setting in unexpected places in your code.  For example,
864 when the code below is run (without the B<-w> flag), the second call
865 to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
866 the first will not.
867
868     sub doit
869     {
870         my $b; chop $b;
871     }
872
873     doit();
874
875     {
876         local ($^W) = 1;
877         doit()
878     }
879
880 This is a side-effect of C<$^W> being dynamically scoped.
881
882 Lexical warnings get around these limitations by allowing finer control
883 over where warnings can or can't be tripped.
884
885 =head2 Controlling Warnings from the Command Line
886
887 There are three Command Line flags that can be used to control when
888 warnings are (or aren't) produced:
889
890 =over 5
891
892 =item B<-w>
893 X<-w>
894
895 This is  the existing flag.  If the lexical warnings pragma is B<not>
896 used in any of you code, or any of the modules that you use, this flag
897 will enable warnings everywhere.  See L<Backward Compatibility> for
898 details of how this flag interacts with lexical warnings.
899
900 =item B<-W>
901 X<-W>
902
903 If the B<-W> flag is used on the command line, it will enable all warnings
904 throughout the program regardless of whether warnings were disabled
905 locally using C<no warnings> or C<$^W =0>.
906 This includes all files that get
907 included via C<use>, C<require> or C<do>.
908 Think of it as the Perl equivalent of the "lint" command.
909
910 =item B<-X>
911 X<-X>
912
913 Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
914
915 =back
916
917 =head2 Backward Compatibility
918
919 If you are used to working with a version of Perl prior to the
920 introduction of lexically scoped warnings, or have code that uses both
921 lexical warnings and C<$^W>, this section will describe how they interact.
922
923 How Lexical Warnings interact with B<-w>/C<$^W>:
924
925 =over 5
926
927 =item 1.
928
929 If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
930 control warnings is used and neither C<$^W> nor the C<warnings> pragma
931 are used, then default warnings will be enabled and optional warnings
932 disabled.
933 This means that legacy code that doesn't attempt to control the warnings
934 will work unchanged.
935
936 =item 2.
937
938 The B<-w> flag just sets the global C<$^W> variable as in 5.005.  This
939 means that any legacy code that currently relies on manipulating C<$^W>
940 to control warning behavior will still work as is.
941
942 =item 3.
943
944 Apart from now being a boolean, the C<$^W> variable operates in exactly
945 the same horrible uncontrolled global way, except that it cannot
946 disable/enable default warnings.
947
948 =item 4.
949
950 If a piece of code is under the control of the C<warnings> pragma,
951 both the C<$^W> variable and the B<-w> flag will be ignored for the
952 scope of the lexical warning.
953
954 =item 5.
955
956 The only way to override a lexical warnings setting is with the B<-W>
957 or B<-X> command line flags.
958
959 =back
960
961 The combined effect of 3 & 4 is that it will allow code which uses
962 the C<warnings> pragma to control the warning behavior of $^W-type
963 code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
964
965 =head2 Category Hierarchy
966 X<warning, categories>
967
968 A hierarchy of "categories" have been defined to allow groups of warnings
969 to be enabled/disabled in isolation.
970
971 The current hierarchy is:
972
973 =for warnings.pl tree-goes-here
974
975 Just like the "strict" pragma any of these categories can be combined
976
977     use warnings qw(void redefine);
978     no warnings qw(io syntax untie);
979
980 Also like the "strict" pragma, if there is more than one instance of the
981 C<warnings> pragma in a given scope the cumulative effect is additive.
982
983     use warnings qw(void); # only "void" warnings enabled
984     ...
985     use warnings qw(io);   # only "void" & "io" warnings enabled
986     ...
987     no warnings qw(void);  # only "io" warnings enabled
988
989 To determine which category a specific warning has been assigned to see
990 L<perldiag>.
991
992 Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
993 sub-category of the "syntax" category.  It is now a top-level category
994 in its own right.
995
996 Note: Before 5.21.0, the "missing" lexical warnings category was
997 internally defined to be the same as the "uninitialized" category. It
998 is now a top-level category in its own right.
999
1000 =head2 Fatal Warnings
1001 X<warning, fatal>
1002
1003 The presence of the word "FATAL" in the category list will escalate
1004 warnings in those categories into fatal errors in that lexical scope.
1005
1006 B<NOTE:> FATAL warnings should be used with care, particularly
1007 C<< FATAL => 'all' >>.
1008
1009 Libraries using L<warnings::warn|/FUNCTIONS> for custom warning categories
1010 generally don't expect L<warnings::warn|/FUNCTIONS> to be fatal and can wind up
1011 in an unexpected state as a result.  For XS modules issuing categorized
1012 warnings, such unanticipated exceptions could also expose memory leak bugs.
1013
1014 Moreover, the Perl interpreter itself has had serious bugs involving
1015 fatalized warnings.  For a summary of resolved and unresolved problems as
1016 of January 2015, please see
1017 L<this perl5-porters post|http://www.nntp.perl.org/group/perl.perl5.porters/2015/01/msg225235.html>.
1018
1019 While some developers find fatalizing some warnings to be a useful
1020 defensive programming technique, using C<< FATAL => 'all' >> to fatalize
1021 all possible warning categories -- including custom ones -- is particularly
1022 risky.  Therefore, the use of C<< FATAL => 'all' >> is
1023 L<discouraged|perlpolicy/discouraged>.
1024
1025 The L<strictures|strictures/VERSION-2> module on CPAN offers one example of
1026 a warnings subset that the module's authors believe is relatively safe to
1027 fatalize.
1028
1029 B<NOTE:> users of FATAL warnings, especially those using
1030 C<< FATAL => 'all' >>, should be fully aware that they are risking future
1031 portability of their programs by doing so.  Perl makes absolutely no
1032 commitments to not introduce new warnings or warnings categories in the
1033 future; indeed, we explicitly reserve the right to do so.  Code that may
1034 not warn now may warn in a future release of Perl if the Perl5 development
1035 team deems it in the best interests of the community to do so.  Should code
1036 using FATAL warnings break due to the introduction of a new warning we will
1037 NOT consider it an incompatible change.  Users of FATAL warnings should
1038 take special caution during upgrades to check to see if their code triggers
1039 any new warnings and should pay particular attention to the fine print of
1040 the documentation of the features they use to ensure they do not exploit
1041 features that are documented as risky, deprecated, or unspecified, or where
1042 the documentation says "so don't do that", or anything with the same sense
1043 and spirit.  Use of such features in combination with FATAL warnings is
1044 ENTIRELY AT THE USER'S RISK.
1045
1046 The following documentation describes how to use FATAL warnings but the
1047 perl5 porters strongly recommend that you understand the risks before doing
1048 so, especially for library code intended for use by others, as there is no
1049 way for downstream users to change the choice of fatal categories.
1050
1051 In the code below, the use of C<time>, C<length>
1052 and C<join> can all produce a C<"Useless use of xxx in void context">
1053 warning.
1054
1055     use warnings;
1056
1057     time;
1058
1059     {
1060         use warnings FATAL => qw(void);
1061         length "abc";
1062     }
1063
1064     join "", 1,2,3;
1065
1066     print "done\n";
1067
1068 When run it produces this output
1069
1070     Useless use of time in void context at fatal line 3.
1071     Useless use of length in void context at fatal line 7.
1072
1073 The scope where C<length> is used has escalated the C<void> warnings
1074 category into a fatal error, so the program terminates immediately when it
1075 encounters the warning.
1076
1077 To explicitly turn off a "FATAL" warning you just disable the warning
1078 it is associated with.  So, for example, to disable the "void" warning
1079 in the example above, either of these will do the trick:
1080
1081     no warnings qw(void);
1082     no warnings FATAL => qw(void);
1083
1084 If you want to downgrade a warning that has been escalated into a fatal
1085 error back to a normal warning, you can use the "NONFATAL" keyword.  For
1086 example, the code below will promote all warnings into fatal errors,
1087 except for those in the "syntax" category.
1088
1089     use warnings FATAL => 'all', NONFATAL => 'syntax';
1090
1091 As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
1092 use:
1093
1094    use v5.20;       # Perl 5.20 or greater is required for the following
1095    use warnings 'FATAL';  # short form of "use warnings FATAL => 'all';"
1096
1097 If you want your program to be compatible with versions of Perl before
1098 5.20, you must use C<< use warnings FATAL => 'all'; >> instead.  (In
1099 previous versions of Perl, the behavior of the statements
1100 C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
1101 C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
1102 they included the C<< => 'all' >> portion.  As of 5.20, they do.)
1103
1104 =head2 Reporting Warnings from a Module
1105 X<warning, reporting> X<warning, registering>
1106
1107 The C<warnings> pragma provides a number of functions that are useful for
1108 module authors.  These are used when you want to report a module-specific
1109 warning to a calling module has enabled warnings via the C<warnings>
1110 pragma.
1111
1112 Consider the module C<MyMod::Abc> below.
1113
1114     package MyMod::Abc;
1115
1116     use warnings::register;
1117
1118     sub open {
1119         my $path = shift;
1120         if ($path !~ m#^/#) {
1121             warnings::warn("changing relative path to /var/abc")
1122                 if warnings::enabled();
1123             $path = "/var/abc/$path";
1124         }
1125     }
1126
1127     1;
1128
1129 The call to C<warnings::register> will create a new warnings category
1130 called "MyMod::Abc", i.e. the new category name matches the current
1131 package name.  The C<open> function in the module will display a warning
1132 message if it gets given a relative path as a parameter.  This warnings
1133 will only be displayed if the code that uses C<MyMod::Abc> has actually
1134 enabled them with the C<warnings> pragma like below.
1135
1136     use MyMod::Abc;
1137     use warnings 'MyMod::Abc';
1138     ...
1139     abc::open("../fred.txt");
1140
1141 It is also possible to test whether the pre-defined warnings categories are
1142 set in the calling module with the C<warnings::enabled> function.  Consider
1143 this snippet of code:
1144
1145     package MyMod::Abc;
1146
1147     sub open {
1148         if (warnings::enabled("deprecated")) {
1149             warnings::warn("deprecated",
1150                            "open is deprecated, use new instead");
1151         }
1152         new(@_);
1153     }
1154
1155     sub new
1156     ...
1157     1;
1158
1159 The function C<open> has been deprecated, so code has been included to
1160 display a warning message whenever the calling module has (at least) the
1161 "deprecated" warnings category enabled.  Something like this, say.
1162
1163     use warnings 'deprecated';
1164     use MyMod::Abc;
1165     ...
1166     MyMod::Abc::open($filename);
1167
1168 Either the C<warnings::warn> or C<warnings::warnif> function should be
1169 used to actually display the warnings message.  This is because they can
1170 make use of the feature that allows warnings to be escalated into fatal
1171 errors.  So in this case
1172
1173     use MyMod::Abc;
1174     use warnings FATAL => 'MyMod::Abc';
1175     ...
1176     MyMod::Abc::open('../fred.txt');
1177
1178 the C<warnings::warnif> function will detect this and die after
1179 displaying the warning message.
1180
1181 The three warnings functions, C<warnings::warn>, C<warnings::warnif>
1182 and C<warnings::enabled> can optionally take an object reference in place
1183 of a category name.  In this case the functions will use the class name
1184 of the object as the warnings category.
1185
1186 Consider this example:
1187
1188     package Original;
1189
1190     no warnings;
1191     use warnings::register;
1192
1193     sub new
1194     {
1195         my $class = shift;
1196         bless [], $class;
1197     }
1198
1199     sub check
1200     {
1201         my $self = shift;
1202         my $value = shift;
1203
1204         if ($value % 2 && warnings::enabled($self))
1205           { warnings::warn($self, "Odd numbers are unsafe") }
1206     }
1207
1208     sub doit
1209     {
1210         my $self = shift;
1211         my $value = shift;
1212         $self->check($value);
1213         # ...
1214     }
1215
1216     1;
1217
1218     package Derived;
1219
1220     use warnings::register;
1221     use Original;
1222     our @ISA = qw( Original );
1223     sub new
1224     {
1225         my $class = shift;
1226         bless [], $class;
1227     }
1228
1229
1230     1;
1231
1232 The code below makes use of both modules, but it only enables warnings from
1233 C<Derived>.
1234
1235     use Original;
1236     use Derived;
1237     use warnings 'Derived';
1238     my $a = Original->new();
1239     $a->doit(1);
1240     my $b = Derived->new();
1241     $a->doit(1);
1242
1243 When this code is run only the C<Derived> object, C<$b>, will generate
1244 a warning.
1245
1246     Odd numbers are unsafe at main.pl line 7
1247
1248 Notice also that the warning is reported at the line where the object is first
1249 used.
1250
1251 When registering new categories of warning, you can supply more names to
1252 warnings::register like this:
1253
1254     package MyModule;
1255     use warnings::register qw(format precision);
1256
1257     ...
1258
1259     warnings::warnif('MyModule::format', '...');
1260
1261 =head1 FUNCTIONS
1262
1263 =over 4
1264
1265 =item use warnings::register
1266
1267 Creates a new warnings category with the same name as the package where
1268 the call to the pragma is used.
1269
1270 =item warnings::enabled()
1271
1272 Use the warnings category with the same name as the current package.
1273
1274 Return TRUE if that warnings category is enabled in the calling module.
1275 Otherwise returns FALSE.
1276
1277 =item warnings::enabled($category)
1278
1279 Return TRUE if the warnings category, C<$category>, is enabled in the
1280 calling module.
1281 Otherwise returns FALSE.
1282
1283 =item warnings::enabled($object)
1284
1285 Use the name of the class for the object reference, C<$object>, as the
1286 warnings category.
1287
1288 Return TRUE if that warnings category is enabled in the first scope
1289 where the object is used.
1290 Otherwise returns FALSE.
1291
1292 =item warnings::fatal_enabled()
1293
1294 Return TRUE if the warnings category with the same name as the current
1295 package has been set to FATAL in the calling module.
1296 Otherwise returns FALSE.
1297
1298 =item warnings::fatal_enabled($category)
1299
1300 Return TRUE if the warnings category C<$category> has been set to FATAL in
1301 the calling module.
1302 Otherwise returns FALSE.
1303
1304 =item warnings::fatal_enabled($object)
1305
1306 Use the name of the class for the object reference, C<$object>, as the
1307 warnings category.
1308
1309 Return TRUE if that warnings category has been set to FATAL in the first
1310 scope where the object is used.
1311 Otherwise returns FALSE.
1312
1313 =item warnings::warn($message)
1314
1315 Print C<$message> to STDERR.
1316
1317 Use the warnings category with the same name as the current package.
1318
1319 If that warnings category has been set to "FATAL" in the calling module
1320 then die. Otherwise return.
1321
1322 =item warnings::warn($category, $message)
1323
1324 Print C<$message> to STDERR.
1325
1326 If the warnings category, C<$category>, has been set to "FATAL" in the
1327 calling module then die. Otherwise return.
1328
1329 =item warnings::warn($object, $message)
1330
1331 Print C<$message> to STDERR.
1332
1333 Use the name of the class for the object reference, C<$object>, as the
1334 warnings category.
1335
1336 If that warnings category has been set to "FATAL" in the scope where C<$object>
1337 is first used then die. Otherwise return.
1338
1339
1340 =item warnings::warnif($message)
1341
1342 Equivalent to:
1343
1344     if (warnings::enabled())
1345       { warnings::warn($message) }
1346
1347 =item warnings::warnif($category, $message)
1348
1349 Equivalent to:
1350
1351     if (warnings::enabled($category))
1352       { warnings::warn($category, $message) }
1353
1354 =item warnings::warnif($object, $message)
1355
1356 Equivalent to:
1357
1358     if (warnings::enabled($object))
1359       { warnings::warn($object, $message) }
1360
1361 =item warnings::register_categories(@names)
1362
1363 This registers warning categories for the given names and is primarily for
1364 use by the warnings::register pragma.
1365
1366 =back
1367
1368 See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.
1369
1370 =cut