Mercurial > repo

comparison perl-5.22.2/regen/warnings.pl @ 8045:a16537d2fe07

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