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