This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix uninitialized-value warnings in Thread::Queue
[perl5.git] / regen / warnings.pl
CommitLineData
599cee73 1#!/usr/bin/perl
6294c161
DM
2#
3# Regenerate (overwriting only if changed):
4#
5# lib/warnings.pm
f2a78a48 6# pod/perllexwarn.pod
6294c161
DM
7# warnings.h
8#
9# from information hardcoded into this script (the $tree hash), plus the
f2a78a48
FC
10# template for warnings.pm in the DATA section. Only part of
11# pod/perllexwarn.pod (the warnings category hierarchy) is generated,
12# the other parts remaining untouched.
6294c161 13#
91efc02c
KW
14# When changing the number of warnings, t/op/caller.t should change to
15# correspond with the value of $BYTES in lib/warnings.pm
8457b38f 16#
6294c161
DM
17# With an argument of 'tree', just dump the contents of $tree and exits.
18# Also accepts the standard regen_lib -q and -v args.
19#
20# This script is normally invoked from regen.pl.
599cee73 21
c8028aa6 22$VERSION = '1.02_05';
b75c8c73 23
73f0cc2d 24BEGIN {
af001346 25 require 'regen/regen_lib.pl';
b6b9a099 26 push @INC, './lib';
73f0cc2d 27}
599cee73
PM
28use strict ;
29
30sub DEFAULT_ON () { 1 }
31sub DEFAULT_OFF () { 2 }
32
33my $tree = {
d3a7d8c7 34
0d658bf5
PM
35'all' => [ 5.008, {
36 'io' => [ 5.008, {
37 'pipe' => [ 5.008, DEFAULT_OFF],
38 'unopened' => [ 5.008, DEFAULT_OFF],
39 'closed' => [ 5.008, DEFAULT_OFF],
40 'newline' => [ 5.008, DEFAULT_OFF],
41 'exec' => [ 5.008, DEFAULT_OFF],
42 'layer' => [ 5.008, DEFAULT_OFF],
c8028aa6 43 'syscalls' => [ 5.019, DEFAULT_OFF],
0d658bf5
PM
44 }],
45 'syntax' => [ 5.008, {
46 'ambiguous' => [ 5.008, DEFAULT_OFF],
47 'semicolon' => [ 5.008, DEFAULT_OFF],
48 'precedence' => [ 5.008, DEFAULT_OFF],
49 'bareword' => [ 5.008, DEFAULT_OFF],
50 'reserved' => [ 5.008, DEFAULT_OFF],
51 'digit' => [ 5.008, DEFAULT_OFF],
52 'parenthesis' => [ 5.008, DEFAULT_OFF],
53 'printf' => [ 5.008, DEFAULT_OFF],
54 'prototype' => [ 5.008, DEFAULT_OFF],
55 'qw' => [ 5.008, DEFAULT_OFF],
197afce1 56 'illegalproto' => [ 5.011, DEFAULT_OFF],
0d658bf5
PM
57 }],
58 'severe' => [ 5.008, {
59 'inplace' => [ 5.008, DEFAULT_ON],
7fc874e8 60 'internal' => [ 5.008, DEFAULT_OFF],
0d658bf5
PM
61 'debugging' => [ 5.008, DEFAULT_ON],
62 'malloc' => [ 5.008, DEFAULT_ON],
c8028aa6 63 }],
7fc874e8 64 'deprecated' => [ 5.008, DEFAULT_ON],
0d658bf5
PM
65 'void' => [ 5.008, DEFAULT_OFF],
66 'recursion' => [ 5.008, DEFAULT_OFF],
67 'redefine' => [ 5.008, DEFAULT_OFF],
68 'numeric' => [ 5.008, DEFAULT_OFF],
69 'uninitialized' => [ 5.008, DEFAULT_OFF],
70 'once' => [ 5.008, DEFAULT_OFF],
71 'misc' => [ 5.008, DEFAULT_OFF],
72 'regexp' => [ 5.008, DEFAULT_OFF],
7fc874e8 73 'glob' => [ 5.008, DEFAULT_ON],
0d658bf5
PM
74 'untie' => [ 5.008, DEFAULT_OFF],
75 'substr' => [ 5.008, DEFAULT_OFF],
76 'taint' => [ 5.008, DEFAULT_OFF],
77 'signal' => [ 5.008, DEFAULT_OFF],
78 'closure' => [ 5.008, DEFAULT_OFF],
79 'overflow' => [ 5.008, DEFAULT_OFF],
80 'portable' => [ 5.008, DEFAULT_OFF],
8457b38f
KW
81 'utf8' => [ 5.008, {
82 'surrogate' => [ 5.013, DEFAULT_OFF],
83 'nonchar' => [ 5.013, DEFAULT_OFF],
84 'non_unicode' => [ 5.013, DEFAULT_OFF],
85 }],
0d658bf5
PM
86 'exiting' => [ 5.008, DEFAULT_OFF],
87 'pack' => [ 5.008, DEFAULT_OFF],
88 'unpack' => [ 5.008, DEFAULT_OFF],
38875929 89 'threads' => [ 5.008, DEFAULT_OFF],
b88df990 90 'imprecision' => [ 5.011, DEFAULT_OFF],
6f87cb12 91 'experimental' => [ 5.017, {
f1d34ca8 92 'experimental::lexical_subs' =>
6f87cb12 93 [ 5.017, DEFAULT_ON ],
db620012
KW
94 'experimental::regex_sets' =>
95 [ 5.017, DEFAULT_ON ],
4055dbce
RS
96 'experimental::lexical_topic' =>
97 [ 5.017, DEFAULT_ON ],
0f539b13
BF
98 'experimental::smartmatch' =>
99 [ 5.017, DEFAULT_ON ],
1f25714a
FC
100 'experimental::postderef' =>
101 [ 5.019, DEFAULT_ON ],
d401967c 102 'experimental::autoderef' =>
0953b66b 103 [ 5.019, DEFAULT_ON ],
30d9c59b
Z
104 'experimental::signatures' =>
105 [ 5.019, DEFAULT_ON ],
6f87cb12 106 }],
8fa7688f 107
0d658bf5
PM
108 #'default' => [ 5.008, DEFAULT_ON ],
109 }],
d3a7d8c7 110} ;
599cee73 111
7fc874e8 112my @def ;
599cee73
PM
113my %list ;
114my %Value ;
0d658bf5
PM
115my %ValueToName ;
116my %NameToValue ;
599cee73 117
0d658bf5
PM
118my %v_list = () ;
119
120sub valueWalk
121{
122 my $tre = shift ;
123 my @list = () ;
124 my ($k, $v) ;
125
126 foreach $k (sort keys %$tre) {
127 $v = $tre->{$k};
128 die "duplicate key $k\n" if defined $list{$k} ;
129 die "Value associated with key '$k' is not an ARRAY reference"
130 if !ref $v || ref $v ne 'ARRAY' ;
131
132 my ($ver, $rest) = @{ $v } ;
133 push @{ $v_list{$ver} }, $k;
134
135 if (ref $rest)
136 { valueWalk ($rest) }
137
138 }
139
140}
141
142sub orderValues
143{
144 my $index = 0;
145 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
146 foreach my $name (@{ $v_list{$ver} } ) {
147 $ValueToName{ $index } = [ uc $name, $ver ] ;
148 $NameToValue{ uc $name } = $index ++ ;
149 }
150 }
151
152 return $index ;
153}
154
155###########################################################################
156
599cee73
PM
157sub walk
158{
159 my $tre = shift ;
160 my @list = () ;
161 my ($k, $v) ;
162
95dfd3ab
GS
163 foreach $k (sort keys %$tre) {
164 $v = $tre->{$k};
599cee73 165 die "duplicate key $k\n" if defined $list{$k} ;
0d658bf5
PM
166 die "Can't find key '$k'"
167 if ! defined $NameToValue{uc $k} ;
168 push @{ $list{$k} }, $NameToValue{uc $k} ;
169 die "Value associated with key '$k' is not an ARRAY reference"
170 if !ref $v || ref $v ne 'ARRAY' ;
171
172 my ($ver, $rest) = @{ $v } ;
173 if (ref $rest)
174 { push (@{ $list{$k} }, walk ($rest)) }
7fc874e8
FC
175 elsif ($rest == DEFAULT_ON)
176 { push @def, $NameToValue{uc $k} }
0d658bf5 177
599cee73
PM
178 push @list, @{ $list{$k} } ;
179 }
180
181 return @list ;
599cee73
PM
182}
183
184###########################################################################
185
186sub mkRange
187{
188 my @a = @_ ;
189 my @out = @a ;
599cee73 190
e95a9fc2 191 for my $i (1 .. @a - 1) {
0ca4541c 192 $out[$i] = ".."
e95a9fc2
KW
193 if $a[$i] == $a[$i - 1] + 1
194 && ($i >= @a - 1 || $a[$i] + 1 == $a[$i + 1] );
599cee73 195 }
e95a9fc2 196 $out[-1] = $a[-1] if $out[-1] eq "..";
599cee73
PM
197
198 my $out = join(",",@out);
199
200 $out =~ s/,(\.\.,)+/../g ;
201 return $out;
202}
203
204###########################################################################
e476b1b5
GS
205sub printTree
206{
207 my $tre = shift ;
208 my $prefix = shift ;
e476b1b5
GS
209 my ($k, $v) ;
210
211 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
0d658bf5 212 my @keys = sort keys %$tre ;
e476b1b5 213
0d658bf5 214 while ($k = shift @keys) {
e476b1b5 215 $v = $tre->{$k};
0d658bf5
PM
216 die "Value associated with key '$k' is not an ARRAY reference"
217 if !ref $v || ref $v ne 'ARRAY' ;
218
219 my $offset ;
220 if ($tre ne $tree) {
221 print $prefix . "|\n" ;
222 print $prefix . "+- $k" ;
223 $offset = ' ' x ($max + 4) ;
224 }
225 else {
226 print $prefix . "$k" ;
227 $offset = ' ' x ($max + 1) ;
228 }
229
230 my ($ver, $rest) = @{ $v } ;
f1d34ca8 231 if (ref $rest)
0ca4541c 232 {
0d658bf5
PM
233 my $bar = @keys ? "|" : " ";
234 print " -" . "-" x ($max - length $k ) . "+\n" ;
235 printTree ($rest, $prefix . $bar . $offset )
e476b1b5
GS
236 }
237 else
238 { print "\n" }
239 }
240
241}
242
243###########################################################################
599cee73 244
317ea90d 245sub mkHexOct
599cee73 246{
317ea90d 247 my ($f, $max, @a) = @_ ;
599cee73
PM
248 my $mask = "\x00" x $max ;
249 my $string = "" ;
250
251 foreach (@a) {
252 vec($mask, $_, 1) = 1 ;
253 }
254
599cee73 255 foreach (unpack("C*", $mask)) {
317ea90d
MS
256 if ($f eq 'x') {
257 $string .= '\x' . sprintf("%2.2x", $_)
258 }
259 else {
260 $string .= '\\' . sprintf("%o", $_)
261 }
599cee73
PM
262 }
263 return $string ;
264}
265
317ea90d
MS
266sub mkHex
267{
268 my($max, @a) = @_;
269 return mkHexOct("x", $max, @a);
270}
271
272sub mkOct
273{
274 my($max, @a) = @_;
275 return mkHexOct("o", $max, @a);
276}
277
599cee73
PM
278###########################################################################
279
e476b1b5
GS
280if (@ARGV && $ARGV[0] eq "tree")
281{
0d658bf5 282 printTree($tree, " ") ;
e476b1b5
GS
283 exit ;
284}
599cee73 285
cc49830d
NC
286my ($warn, $pm) = map {
287 open_new($_, '>', { by => 'regen/warnings.pl' });
288} 'warnings.h', 'lib/warnings.pm';
599cee73 289
cc49830d 290print $warn <<'EOM';
599cee73 291
0453d815
PM
292#define Off(x) ((x) / 8)
293#define Bit(x) (1 << ((x) % 8))
599cee73
PM
294#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
295
0453d815 296
599cee73 297#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 298#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
299#define G_WARN_ALL_ON 2 /* -W flag */
300#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 301#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
302#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
303
a0714e2c 304#define pWARN_STD NULL
72dc9ed5
NC
305#define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
306#define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
599cee73 307
d3a7d8c7
GS
308#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
309 (x) == pWARN_NONE)
5f2d9966
DM
310
311/* if PL_warnhook is set to this value, then warnings die */
06dcd5bf 312#define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
599cee73
PM
313EOM
314
d3a7d8c7
GS
315my $offset = 0 ;
316
0d658bf5
PM
317valueWalk ($tree) ;
318my $index = orderValues();
599cee73 319
12bcd1a6
PM
320die <<EOM if $index > 255 ;
321Too many warnings categories -- max is 255
322 rewrite packWARN* & unpackWARN* macros
323EOM
599cee73 324
0d658bf5
PM
325walk ($tree) ;
326
599cee73
PM
327$index *= 2 ;
328my $warn_size = int($index / 8) + ($index % 8 != 0) ;
329
330my $k ;
0d658bf5
PM
331my $last_ver = 0;
332foreach $k (sort { $a <=> $b } keys %ValueToName) {
333 my ($name, $version) = @{ $ValueToName{$k} };
424a4936 334 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
0d658bf5 335 if $last_ver != $version ;
6f87cb12
FC
336 $name =~ y/:/_/;
337 print $warn tab(5, "#define WARN_$name"), " $k\n" ;
0d658bf5 338 $last_ver = $version ;
599cee73 339}
424a4936 340print $warn "\n" ;
599cee73 341
424a4936 342print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
599cee73 343#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
424a4936
NC
344print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
345print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
599cee73 346
424a4936 347print $warn <<'EOM';
599cee73 348
d5a71f30
GS
349#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
350#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
351#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
72dc9ed5
NC
352#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
353#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
354
355#define DUP_WARNINGS(p) \
594cd643
NC
356 (specialWARN(p) ? (STRLEN*)(p) \
357 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
358 char))
d5a71f30 359
f54ba1c2 360#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
7c08c4c5
KW
361
362/* The w1, w2 ... should be independent warnings categories; one shouldn't be
363 * a subcategory of any other */
364
f54ba1c2
DM
365#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
366#define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
367#define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
368
369#define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
370#define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
371#define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
372#define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
12bcd1a6 373
98fe6610
NC
374#define WARNshift 8
375
3b9e3074 376#define packWARN(a) (a )
7c08c4c5
KW
377
378/* The a, b, ... should be independent warnings categories; one shouldn't be
379 * a subcategory of any other */
380
3b9e3074
SH
381#define packWARN2(a,b) ((a) | ((b)<<8) )
382#define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
383#define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
12bcd1a6
PM
384
385#define unpackWARN1(x) ((x) & 0xFF)
386#define unpackWARN2(x) (((x) >>8) & 0xFF)
387#define unpackWARN3(x) (((x) >>16) & 0xFF)
388#define unpackWARN4(x) (((x) >>24) & 0xFF)
389
390#define ckDEAD(x) \
391 ( ! specialWARN(PL_curcop->cop_warnings) && \
392 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
393 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
394 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
395 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
396 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
397
4438c4b7 398/* end of file warnings.h */
599cee73
PM
399EOM
400
ce716c52 401read_only_bottom_close_and_rename($warn);
599cee73
PM
402
403while (<DATA>) {
404 last if /^KEYWORDS$/ ;
424a4936 405 print $pm $_ ;
599cee73
PM
406}
407
0d658bf5 408$last_ver = 0;
424a4936 409print $pm "our %Offsets = (\n" ;
0d658bf5
PM
410foreach my $k (sort { $a <=> $b } keys %ValueToName) {
411 my ($name, $version) = @{ $ValueToName{$k} };
412 $name = lc $name;
d3a7d8c7 413 $k *= 2 ;
0d658bf5 414 if ( $last_ver != $version ) {
424a4936
NC
415 print $pm "\n";
416 print $pm tab(4, " # Warnings Categories added in Perl $version");
417 print $pm "\n\n";
0d658bf5 418 }
424a4936 419 print $pm tab(4, " '$name'"), "=> $k,\n" ;
0d658bf5 420 $last_ver = $version;
d3a7d8c7
GS
421}
422
424a4936 423print $pm " );\n\n" ;
d3a7d8c7 424
424a4936 425print $pm "our %Bits = (\n" ;
599cee73
PM
426foreach $k (sort keys %list) {
427
428 my $v = $list{$k} ;
429 my @list = sort { $a <=> $b } @$v ;
430
424a4936 431 print $pm tab(4, " '$k'"), '=> "',
0ca4541c 432 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
433 '", # [', mkRange(@list), "]\n" ;
434}
435
424a4936 436print $pm " );\n\n" ;
599cee73 437
424a4936 438print $pm "our %DeadBits = (\n" ;
599cee73
PM
439foreach $k (sort keys %list) {
440
441 my $v = $list{$k} ;
442 my @list = sort { $a <=> $b } @$v ;
443
424a4936 444 print $pm tab(4, " '$k'"), '=> "',
0ca4541c 445 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
446 '", # [', mkRange(@list), "]\n" ;
447}
448
424a4936
NC
449print $pm " );\n\n" ;
450print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
7fc874e8
FC
451print $pm '$DEFAULT = "', mkHex($warn_size, map $_ * 2, @def),
452 '", # [', mkRange(@def), "]\n" ;
424a4936
NC
453print $pm '$LAST_BIT = ' . "$index ;\n" ;
454print $pm '$BYTES = ' . "$warn_size ;\n" ;
599cee73 455while (<DATA>) {
424a4936 456 print $pm $_ ;
599cee73
PM
457}
458
ce716c52 459read_only_bottom_close_and_rename($pm);
599cee73 460
f2a78a48
FC
461my $lexwarn = open_new 'pod/perllexwarn.pod', '>';
462open my $oldlexwarn, "pod/perllexwarn.pod"
463 or die "$0 cannot open pod/perllexwarn.pod for reading: $!";
464select +(select($lexwarn), do {
465 while(<$oldlexwarn>) {
466 print;
467 last if /=for warnings.pl begin/;
468 }
469 print "\n";
470 printTree($tree, " ") ;
471 print "\n";
472 while(<$oldlexwarn>) {
473 last if /=for warnings.pl end/;
474 }
475 do { print } while <$oldlexwarn>;
476})[0];
477
478close_and_rename($lexwarn);
479
599cee73 480__END__
4438c4b7 481package warnings;
599cee73 482
76ff28b8 483our $VERSION = '1.22';
f2c3e829
RGS
484
485# Verify that we're called correctly so that warnings will work.
486# see also strict.pm.
5108dc18 487unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
f2c3e829 488 my (undef, $f, $l) = caller;
5108dc18 489 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
f2c3e829 490}
b75c8c73 491
599cee73
PM
492=head1 NAME
493
4438c4b7 494warnings - Perl pragma to control optional warnings
599cee73
PM
495
496=head1 SYNOPSIS
497
4438c4b7
JH
498 use warnings;
499 no warnings;
599cee73 500
4438c4b7
JH
501 use warnings "all";
502 no warnings "all";
599cee73 503
d3a7d8c7
GS
504 use warnings::register;
505 if (warnings::enabled()) {
506 warnings::warn("some warning");
507 }
508
509 if (warnings::enabled("void")) {
e476b1b5
GS
510 warnings::warn("void", "some warning");
511 }
512
7e6d00f8
PM
513 if (warnings::enabled($object)) {
514 warnings::warn($object, "some warning");
515 }
516
721f911b
PM
517 warnings::warnif("some warning");
518 warnings::warnif("void", "some warning");
519 warnings::warnif($object, "some warning");
7e6d00f8 520
599cee73
PM
521=head1 DESCRIPTION
522
fe2e802c
EM
523The C<warnings> pragma is a replacement for the command line flag C<-w>,
524but the pragma is limited to the enclosing block, while the flag is global.
28726416
DG
525See L<perllexwarn> for more information and the list of built-in warning
526categories.
fe2e802c 527
0453d815
PM
528If no import list is supplied, all possible warnings are either enabled
529or disabled.
599cee73 530
0ca4541c 531A number of functions are provided to assist module authors.
e476b1b5
GS
532
533=over 4
534
d3a7d8c7
GS
535=item use warnings::register
536
7e6d00f8
PM
537Creates a new warnings category with the same name as the package where
538the call to the pragma is used.
539
540=item warnings::enabled()
541
542Use the warnings category with the same name as the current package.
543
544Return TRUE if that warnings category is enabled in the calling module.
545Otherwise returns FALSE.
546
547=item warnings::enabled($category)
548
549Return TRUE if the warnings category, C<$category>, is enabled in the
550calling module.
551Otherwise returns FALSE.
552
553=item warnings::enabled($object)
554
555Use the name of the class for the object reference, C<$object>, as the
556warnings category.
557
558Return TRUE if that warnings category is enabled in the first scope
559where the object is used.
560Otherwise returns FALSE.
561
ec983580
AR
562=item warnings::fatal_enabled()
563
564Return TRUE if the warnings category with the same name as the current
565package has been set to FATAL in the calling module.
566Otherwise returns FALSE.
567
568=item warnings::fatal_enabled($category)
569
570Return TRUE if the warnings category C<$category> has been set to FATAL in
571the calling module.
572Otherwise returns FALSE.
573
574=item warnings::fatal_enabled($object)
575
576Use the name of the class for the object reference, C<$object>, as the
577warnings category.
578
579Return TRUE if that warnings category has been set to FATAL in the first
580scope where the object is used.
581Otherwise returns FALSE.
582
7e6d00f8
PM
583=item warnings::warn($message)
584
585Print C<$message> to STDERR.
586
587Use the warnings category with the same name as the current package.
588
589If that warnings category has been set to "FATAL" in the calling module
590then die. Otherwise return.
591
592=item warnings::warn($category, $message)
593
594Print C<$message> to STDERR.
595
596If the warnings category, C<$category>, has been set to "FATAL" in the
597calling module then die. Otherwise return.
d3a7d8c7 598
7e6d00f8 599=item warnings::warn($object, $message)
e476b1b5 600
7e6d00f8 601Print C<$message> to STDERR.
e476b1b5 602
7e6d00f8
PM
603Use the name of the class for the object reference, C<$object>, as the
604warnings category.
e476b1b5 605
7e6d00f8
PM
606If that warnings category has been set to "FATAL" in the scope where C<$object>
607is first used then die. Otherwise return.
599cee73 608
e476b1b5 609
7e6d00f8
PM
610=item warnings::warnif($message)
611
612Equivalent to:
613
614 if (warnings::enabled())
615 { warnings::warn($message) }
616
617=item warnings::warnif($category, $message)
618
619Equivalent to:
620
621 if (warnings::enabled($category))
622 { warnings::warn($category, $message) }
623
624=item warnings::warnif($object, $message)
625
626Equivalent to:
627
628 if (warnings::enabled($object))
629 { warnings::warn($object, $message) }
d3a7d8c7 630
5e7ad92a 631=item warnings::register_categories(@names)
13781810
FR
632
633This registers warning categories for the given names and is primarily for
634use by the warnings::register pragma, for which see L<perllexwarn>.
635
e476b1b5
GS
636=back
637
749f83fa 638See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
639
640=cut
641
599cee73
PM
642KEYWORDS
643
d3a7d8c7
GS
644$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
645
c3186b65
PM
646sub Croaker
647{
4dd71923 648 require Carp; # this initializes %CarpInternal
dbab294c 649 local $Carp::CarpInternal{'warnings'};
c3186b65 650 delete $Carp::CarpInternal{'warnings'};
8becbb3b 651 Carp::croak(@_);
c3186b65
PM
652}
653
4c02ac93
NC
654sub _bits {
655 my $mask = shift ;
599cee73
PM
656 my $catmask ;
657 my $fatal = 0 ;
6e9af7e4
PM
658 my $no_fatal = 0 ;
659
660 foreach my $word ( @_ ) {
661 if ($word eq 'FATAL') {
327afb7f 662 $fatal = 1;
6e9af7e4
PM
663 $no_fatal = 0;
664 }
665 elsif ($word eq 'NONFATAL') {
666 $fatal = 0;
667 $no_fatal = 1;
327afb7f 668 }
d3a7d8c7
GS
669 elsif ($catmask = $Bits{$word}) {
670 $mask |= $catmask ;
671 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 672 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 673 }
d3a7d8c7 674 else
c3186b65 675 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
676 }
677
678 return $mask ;
679}
680
4c02ac93
NC
681sub bits
682{
683 # called from B::Deparse.pm
684 push @_, 'all' unless @_ ;
685 return _bits(undef, @_) ;
686}
687
6e9af7e4
PM
688sub import
689{
599cee73 690 shift;
6e9af7e4 691
7fc874e8 692 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 693
f1f33818
PM
694 if (vec($mask, $Offsets{'all'}, 1)) {
695 $mask |= $Bits{'all'} ;
696 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
697 }
c91312d5
H
698
699 # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
700 push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
6e9af7e4 701
4c02ac93
NC
702 # Empty @_ is equivalent to @_ = 'all' ;
703 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
599cee73
PM
704}
705
6e9af7e4
PM
706sub unimport
707{
599cee73 708 shift;
6e9af7e4
PM
709
710 my $catmask ;
7fc874e8 711 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 712
d3a7d8c7 713 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 714 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
715 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
716 }
6e9af7e4 717
c91312d5
H
718 # append 'all' when implied (empty import list or after a lone "FATAL")
719 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
6e9af7e4
PM
720
721 foreach my $word ( @_ ) {
722 if ($word eq 'FATAL') {
723 next;
724 }
725 elsif ($catmask = $Bits{$word}) {
726 $mask &= ~($catmask | $DeadBits{$word} | $All);
727 }
728 else
729 { Croaker("Unknown warnings category '$word'")}
730 }
731
732 ${^WARNING_BITS} = $mask ;
599cee73
PM
733}
734
9df0f64f 735my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
736
96183d25 737sub MESSAGE () { 4 };
8787a747
NC
738sub FATAL () { 2 };
739sub NORMAL () { 1 };
740
7e6d00f8 741sub __chk
599cee73 742{
d3a7d8c7
GS
743 my $category ;
744 my $offset ;
7e6d00f8 745 my $isobj = 0 ;
8787a747 746 my $wanted = shift;
96183d25
NC
747 my $has_message = $wanted & MESSAGE;
748
749 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
750 my $sub = (caller 1)[3];
751 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
752 Croaker("Usage: $sub($syntax)");
753 }
754
755 my $message = pop if $has_message;
d3a7d8c7
GS
756
757 if (@_) {
758 # check the category supplied.
759 $category = shift ;
9df0f64f 760 if (my $type = ref $category) {
761 Croaker("not an object")
762 if exists $builtin_type{$type};
763 $category = $type;
7e6d00f8
PM
764 $isobj = 1 ;
765 }
d3a7d8c7 766 $offset = $Offsets{$category};
c3186b65 767 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
768 unless defined $offset;
769 }
770 else {
0ca4541c 771 $category = (caller(1))[0] ;
d3a7d8c7 772 $offset = $Offsets{$category};
c3186b65 773 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
774 unless defined $offset ;
775 }
776
f0a8fd68 777 my $i;
7e6d00f8
PM
778
779 if ($isobj) {
f0a8fd68
NC
780 my $pkg;
781 $i = 2;
7e6d00f8
PM
782 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
783 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
784 }
785 $i -= 2 ;
786 }
787 else {
4f527b71 788 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
789 }
790
7fc874e8
FC
791 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
792 # explicitly returns undef.
793 my(@callers_bitmask) = (caller($i))[9] ;
794 my $callers_bitmask =
795 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
8787a747
NC
796
797 my @results;
96183d25 798 foreach my $type (FATAL, NORMAL) {
8787a747
NC
799 next unless $wanted & $type;
800
801 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
802 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
803 }
96183d25
NC
804
805 # &enabled and &fatal_enabled
806 return $results[0] unless $has_message;
807
808 # &warnif, and the category is neither enabled as warning nor as fatal
809 return if $wanted == (NORMAL | FATAL | MESSAGE)
810 && !($results[0] || $results[1]);
811
812 require Carp;
813 Carp::croak($message) if $results[0];
814 # will always get here for &warn. will only get here for &warnif if the
815 # category is enabled
816 Carp::carp($message);
7e6d00f8
PM
817}
818
13781810
FR
819sub _mkMask
820{
821 my ($bit) = @_;
822 my $mask = "";
823
824 vec($mask, $bit, 1) = 1;
825 return $mask;
826}
827
5e7ad92a 828sub register_categories
13781810
FR
829{
830 my @names = @_;
831
832 for my $name (@names) {
833 if (! defined $Bits{$name}) {
834 $Bits{$name} = _mkMask($LAST_BIT);
835 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
836 $Offsets{$name} = $LAST_BIT ++;
837 foreach my $k (keys %Bits) {
838 vec($Bits{$k}, $LAST_BIT, 1) = 0;
839 }
840 $DeadBits{$name} = _mkMask($LAST_BIT);
841 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
842 }
843 }
844}
845
4f527b71 846sub _error_loc {
4dd71923 847 require Carp;
4f527b71 848 goto &Carp::short_error_loc; # don't introduce another stack frame
13781810 849}
4f527b71 850
7e6d00f8
PM
851sub enabled
852{
8787a747 853 return __chk(NORMAL, @_);
599cee73
PM
854}
855
ec983580
AR
856sub fatal_enabled
857{
8787a747 858 return __chk(FATAL, @_);
ec983580 859}
d3a7d8c7 860
e476b1b5
GS
861sub warn
862{
96183d25 863 return __chk(FATAL | MESSAGE, @_);
e476b1b5
GS
864}
865
7e6d00f8
PM
866sub warnif
867{
96183d25 868 return __chk(NORMAL | FATAL | MESSAGE, @_);
7e6d00f8 869}
0d658bf5 870
8787a747
NC
871# These are not part of any public interface, so we can delete them to save
872# space.
b9929960 873delete @warnings::{qw(NORMAL FATAL MESSAGE)};
8787a747 874
599cee73 8751;