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