This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
replace printTree with warningsTree
[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
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 35'all' => [ 5.008, {
c4a853d1 36 'io' => [ 5.008, {
0d658bf5
PM
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 44 }],
c4a853d1 45 'syntax' => [ 5.008, {
0d658bf5
PM
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 57 }],
c4a853d1 58 'severe' => [ 5.008, {
0d658bf5 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;
c4a853d1 134
0d658bf5
PM
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' ;
c4a853d1 171
0d658bf5
PM
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###########################################################################
e15f14b8 205sub warningsTree
e476b1b5
GS
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
e15f14b8
RS
214 my $rv = '';
215
0d658bf5 216 while ($k = shift @keys) {
e476b1b5 217 $v = $tre->{$k};
0d658bf5
PM
218 die "Value associated with key '$k' is not an ARRAY reference"
219 if !ref $v || ref $v ne 'ARRAY' ;
c4a853d1 220
0d658bf5
PM
221 my $offset ;
222 if ($tre ne $tree) {
e15f14b8
RS
223 $rv .= $prefix . "|\n" ;
224 $rv .= $prefix . "+- $k" ;
0d658bf5
PM
225 $offset = ' ' x ($max + 4) ;
226 }
227 else {
e15f14b8 228 $rv .= $prefix . "$k" ;
0d658bf5
PM
229 $offset = ' ' x ($max + 1) ;
230 }
231
232 my ($ver, $rest) = @{ $v } ;
f1d34ca8 233 if (ref $rest)
0ca4541c 234 {
0d658bf5 235 my $bar = @keys ? "|" : " ";
e15f14b8
RS
236 $rv .= " -" . "-" x ($max - length $k ) . "+\n" ;
237 $rv .= warningsTree ($rest, $prefix . $bar . $offset )
e476b1b5
GS
238 }
239 else
e15f14b8 240 { $rv .= "\n" }
e476b1b5
GS
241 }
242
e15f14b8 243 return $rv;
e476b1b5
GS
244}
245
246###########################################################################
599cee73 247
317ea90d 248sub mkHexOct
599cee73 249{
317ea90d 250 my ($f, $max, @a) = @_ ;
599cee73
PM
251 my $mask = "\x00" x $max ;
252 my $string = "" ;
253
254 foreach (@a) {
255 vec($mask, $_, 1) = 1 ;
256 }
257
599cee73 258 foreach (unpack("C*", $mask)) {
317ea90d
MS
259 if ($f eq 'x') {
260 $string .= '\x' . sprintf("%2.2x", $_)
261 }
262 else {
263 $string .= '\\' . sprintf("%o", $_)
264 }
599cee73
PM
265 }
266 return $string ;
267}
268
317ea90d
MS
269sub mkHex
270{
271 my($max, @a) = @_;
272 return mkHexOct("x", $max, @a);
273}
274
275sub mkOct
276{
277 my($max, @a) = @_;
278 return mkHexOct("o", $max, @a);
279}
280
599cee73
PM
281###########################################################################
282
e476b1b5
GS
283if (@ARGV && $ARGV[0] eq "tree")
284{
e15f14b8 285 print warningsTree($tree, " ") ;
e476b1b5
GS
286 exit ;
287}
599cee73 288
cc49830d
NC
289my ($warn, $pm) = map {
290 open_new($_, '>', { by => 'regen/warnings.pl' });
291} 'warnings.h', 'lib/warnings.pm';
599cee73 292
c4a853d1
RS
293my ($index, $warn_size);
294
295{
296 # generate warnings.h
297
298 print $warn <<'EOM';
599cee73 299
0453d815
PM
300#define Off(x) ((x) / 8)
301#define Bit(x) (1 << ((x) % 8))
599cee73
PM
302#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
303
0453d815 304
599cee73 305#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 306#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
307#define G_WARN_ALL_ON 2 /* -W flag */
308#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 309#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
310#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
311
a0714e2c 312#define pWARN_STD NULL
72dc9ed5
NC
313#define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
314#define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
599cee73 315
d3a7d8c7
GS
316#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
317 (x) == pWARN_NONE)
5f2d9966
DM
318
319/* if PL_warnhook is set to this value, then warnings die */
06dcd5bf 320#define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
599cee73
PM
321EOM
322
c4a853d1 323 my $offset = 0 ;
d3a7d8c7 324
c4a853d1
RS
325 valueWalk ($tree) ;
326 $index = orderValues();
599cee73 327
c4a853d1 328 die <<EOM if $index > 255 ;
12bcd1a6 329Too many warnings categories -- max is 255
c4a853d1 330 rewrite packWARN* & unpackWARN* macros
12bcd1a6 331EOM
599cee73 332
c4a853d1 333 walk ($tree) ;
0d658bf5 334
c4a853d1
RS
335 $index *= 2 ;
336 $warn_size = int($index / 8) + ($index % 8 != 0) ;
599cee73 337
c4a853d1
RS
338 my $k ;
339 my $last_ver = 0;
340 foreach $k (sort { $a <=> $b } keys %ValueToName) {
341 my ($name, $version) = @{ $ValueToName{$k} };
342 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
343 if $last_ver != $version ;
344 $name =~ y/:/_/;
345 print $warn tab(5, "#define WARN_$name"), " $k\n" ;
346 $last_ver = $version ;
347 }
348 print $warn "\n" ;
599cee73 349
c4a853d1
RS
350 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
351 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
352 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
599cee73 353
c4a853d1 354 print $warn <<'EOM';
599cee73 355
d5a71f30
GS
356#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
357#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
358#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
72dc9ed5
NC
359#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
360#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
361
362#define DUP_WARNINGS(p) \
594cd643
NC
363 (specialWARN(p) ? (STRLEN*)(p) \
364 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
365 char))
d5a71f30 366
f54ba1c2 367#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
7c08c4c5
KW
368
369/* The w1, w2 ... should be independent warnings categories; one shouldn't be
370 * a subcategory of any other */
371
f54ba1c2
DM
372#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
373#define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
374#define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
375
376#define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
377#define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
378#define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
379#define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
12bcd1a6 380
98fe6610
NC
381#define WARNshift 8
382
3b9e3074 383#define packWARN(a) (a )
7c08c4c5
KW
384
385/* The a, b, ... should be independent warnings categories; one shouldn't be
386 * a subcategory of any other */
387
3b9e3074
SH
388#define packWARN2(a,b) ((a) | ((b)<<8) )
389#define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
390#define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
12bcd1a6
PM
391
392#define unpackWARN1(x) ((x) & 0xFF)
393#define unpackWARN2(x) (((x) >>8) & 0xFF)
394#define unpackWARN3(x) (((x) >>16) & 0xFF)
395#define unpackWARN4(x) (((x) >>24) & 0xFF)
396
397#define ckDEAD(x) \
398 ( ! specialWARN(PL_curcop->cop_warnings) && \
399 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
400 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
401 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
402 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
403 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
404
4438c4b7 405/* end of file warnings.h */
599cee73
PM
406EOM
407
c4a853d1
RS
408 read_only_bottom_close_and_rename($warn);
409}
599cee73
PM
410
411while (<DATA>) {
412 last if /^KEYWORDS$/ ;
424a4936 413 print $pm $_ ;
599cee73
PM
414}
415
c4a853d1 416my $last_ver = 0;
424a4936 417print $pm "our %Offsets = (\n" ;
0d658bf5
PM
418foreach my $k (sort { $a <=> $b } keys %ValueToName) {
419 my ($name, $version) = @{ $ValueToName{$k} };
420 $name = lc $name;
d3a7d8c7 421 $k *= 2 ;
0d658bf5 422 if ( $last_ver != $version ) {
424a4936
NC
423 print $pm "\n";
424 print $pm tab(4, " # Warnings Categories added in Perl $version");
425 print $pm "\n\n";
0d658bf5 426 }
424a4936 427 print $pm tab(4, " '$name'"), "=> $k,\n" ;
0d658bf5 428 $last_ver = $version;
d3a7d8c7
GS
429}
430
424a4936 431print $pm " );\n\n" ;
d3a7d8c7 432
424a4936 433print $pm "our %Bits = (\n" ;
c4a853d1 434foreach my $k (sort keys %list) {
599cee73
PM
435
436 my $v = $list{$k} ;
437 my @list = sort { $a <=> $b } @$v ;
438
424a4936 439 print $pm tab(4, " '$k'"), '=> "',
0ca4541c 440 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
441 '", # [', mkRange(@list), "]\n" ;
442}
443
424a4936 444print $pm " );\n\n" ;
599cee73 445
424a4936 446print $pm "our %DeadBits = (\n" ;
c4a853d1 447foreach my $k (sort keys %list) {
599cee73
PM
448
449 my $v = $list{$k} ;
450 my @list = sort { $a <=> $b } @$v ;
451
424a4936 452 print $pm tab(4, " '$k'"), '=> "',
0ca4541c 453 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
454 '", # [', mkRange(@list), "]\n" ;
455}
456
424a4936
NC
457print $pm " );\n\n" ;
458print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
7fc874e8
FC
459print $pm '$DEFAULT = "', mkHex($warn_size, map $_ * 2, @def),
460 '", # [', mkRange(@def), "]\n" ;
424a4936
NC
461print $pm '$LAST_BIT = ' . "$index ;\n" ;
462print $pm '$BYTES = ' . "$warn_size ;\n" ;
599cee73 463while (<DATA>) {
424a4936 464 print $pm $_ ;
599cee73
PM
465}
466
ce716c52 467read_only_bottom_close_and_rename($pm);
599cee73 468
f2a78a48
FC
469my $lexwarn = open_new 'pod/perllexwarn.pod', '>';
470open my $oldlexwarn, "pod/perllexwarn.pod"
471 or die "$0 cannot open pod/perllexwarn.pod for reading: $!";
472select +(select($lexwarn), do {
473 while(<$oldlexwarn>) {
474 print;
475 last if /=for warnings.pl begin/;
476 }
477 print "\n";
e15f14b8 478 print warningsTree($tree, " ") ;
f2a78a48
FC
479 print "\n";
480 while(<$oldlexwarn>) {
481 last if /=for warnings.pl end/;
482 }
483 do { print } while <$oldlexwarn>;
484})[0];
485
486close_and_rename($lexwarn);
487
599cee73 488__END__
4438c4b7 489package warnings;
599cee73 490
76ff28b8 491our $VERSION = '1.22';
f2c3e829
RGS
492
493# Verify that we're called correctly so that warnings will work.
494# see also strict.pm.
5108dc18 495unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
f2c3e829 496 my (undef, $f, $l) = caller;
5108dc18 497 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
f2c3e829 498}
b75c8c73 499
599cee73
PM
500=head1 NAME
501
4438c4b7 502warnings - Perl pragma to control optional warnings
599cee73
PM
503
504=head1 SYNOPSIS
505
4438c4b7
JH
506 use warnings;
507 no warnings;
599cee73 508
4438c4b7
JH
509 use warnings "all";
510 no warnings "all";
599cee73 511
d3a7d8c7
GS
512 use warnings::register;
513 if (warnings::enabled()) {
514 warnings::warn("some warning");
515 }
516
517 if (warnings::enabled("void")) {
e476b1b5
GS
518 warnings::warn("void", "some warning");
519 }
520
7e6d00f8
PM
521 if (warnings::enabled($object)) {
522 warnings::warn($object, "some warning");
523 }
524
721f911b
PM
525 warnings::warnif("some warning");
526 warnings::warnif("void", "some warning");
527 warnings::warnif($object, "some warning");
7e6d00f8 528
599cee73
PM
529=head1 DESCRIPTION
530
fe2e802c
EM
531The C<warnings> pragma is a replacement for the command line flag C<-w>,
532but the pragma is limited to the enclosing block, while the flag is global.
28726416
DG
533See L<perllexwarn> for more information and the list of built-in warning
534categories.
fe2e802c 535
0453d815
PM
536If no import list is supplied, all possible warnings are either enabled
537or disabled.
599cee73 538
0ca4541c 539A number of functions are provided to assist module authors.
e476b1b5
GS
540
541=over 4
542
d3a7d8c7
GS
543=item use warnings::register
544
7e6d00f8
PM
545Creates a new warnings category with the same name as the package where
546the call to the pragma is used.
547
548=item warnings::enabled()
549
550Use the warnings category with the same name as the current package.
551
552Return TRUE if that warnings category is enabled in the calling module.
553Otherwise returns FALSE.
554
555=item warnings::enabled($category)
556
557Return TRUE if the warnings category, C<$category>, is enabled in the
558calling module.
559Otherwise returns FALSE.
560
561=item warnings::enabled($object)
562
563Use the name of the class for the object reference, C<$object>, as the
564warnings category.
565
566Return TRUE if that warnings category is enabled in the first scope
567where the object is used.
568Otherwise returns FALSE.
569
ec983580
AR
570=item warnings::fatal_enabled()
571
572Return TRUE if the warnings category with the same name as the current
573package has been set to FATAL in the calling module.
574Otherwise returns FALSE.
575
576=item warnings::fatal_enabled($category)
577
578Return TRUE if the warnings category C<$category> has been set to FATAL in
579the calling module.
580Otherwise returns FALSE.
581
582=item warnings::fatal_enabled($object)
583
584Use the name of the class for the object reference, C<$object>, as the
585warnings category.
586
587Return TRUE if that warnings category has been set to FATAL in the first
588scope where the object is used.
589Otherwise returns FALSE.
590
7e6d00f8
PM
591=item warnings::warn($message)
592
593Print C<$message> to STDERR.
594
595Use the warnings category with the same name as the current package.
596
597If that warnings category has been set to "FATAL" in the calling module
598then die. Otherwise return.
599
600=item warnings::warn($category, $message)
601
602Print C<$message> to STDERR.
603
604If the warnings category, C<$category>, has been set to "FATAL" in the
605calling module then die. Otherwise return.
d3a7d8c7 606
7e6d00f8 607=item warnings::warn($object, $message)
e476b1b5 608
7e6d00f8 609Print C<$message> to STDERR.
e476b1b5 610
7e6d00f8
PM
611Use the name of the class for the object reference, C<$object>, as the
612warnings category.
e476b1b5 613
7e6d00f8
PM
614If that warnings category has been set to "FATAL" in the scope where C<$object>
615is first used then die. Otherwise return.
599cee73 616
e476b1b5 617
7e6d00f8
PM
618=item warnings::warnif($message)
619
620Equivalent to:
621
622 if (warnings::enabled())
623 { warnings::warn($message) }
624
625=item warnings::warnif($category, $message)
626
627Equivalent to:
628
629 if (warnings::enabled($category))
630 { warnings::warn($category, $message) }
631
632=item warnings::warnif($object, $message)
633
634Equivalent to:
635
636 if (warnings::enabled($object))
637 { warnings::warn($object, $message) }
d3a7d8c7 638
5e7ad92a 639=item warnings::register_categories(@names)
13781810
FR
640
641This registers warning categories for the given names and is primarily for
642use by the warnings::register pragma, for which see L<perllexwarn>.
643
e476b1b5
GS
644=back
645
749f83fa 646See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
647
648=cut
649
599cee73
PM
650KEYWORDS
651
d3a7d8c7
GS
652$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
653
c3186b65
PM
654sub Croaker
655{
4dd71923 656 require Carp; # this initializes %CarpInternal
dbab294c 657 local $Carp::CarpInternal{'warnings'};
c3186b65 658 delete $Carp::CarpInternal{'warnings'};
8becbb3b 659 Carp::croak(@_);
c3186b65
PM
660}
661
4c02ac93
NC
662sub _bits {
663 my $mask = shift ;
599cee73
PM
664 my $catmask ;
665 my $fatal = 0 ;
6e9af7e4
PM
666 my $no_fatal = 0 ;
667
668 foreach my $word ( @_ ) {
669 if ($word eq 'FATAL') {
327afb7f 670 $fatal = 1;
6e9af7e4
PM
671 $no_fatal = 0;
672 }
673 elsif ($word eq 'NONFATAL') {
674 $fatal = 0;
675 $no_fatal = 1;
327afb7f 676 }
d3a7d8c7
GS
677 elsif ($catmask = $Bits{$word}) {
678 $mask |= $catmask ;
679 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 680 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 681 }
d3a7d8c7 682 else
c3186b65 683 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
684 }
685
686 return $mask ;
687}
688
4c02ac93
NC
689sub bits
690{
691 # called from B::Deparse.pm
692 push @_, 'all' unless @_ ;
693 return _bits(undef, @_) ;
694}
695
c4a853d1 696sub import
6e9af7e4 697{
599cee73 698 shift;
6e9af7e4 699
7fc874e8 700 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 701
f1f33818
PM
702 if (vec($mask, $Offsets{'all'}, 1)) {
703 $mask |= $Bits{'all'} ;
704 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
705 }
c91312d5
H
706
707 # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
708 push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
c4a853d1 709
4c02ac93
NC
710 # Empty @_ is equivalent to @_ = 'all' ;
711 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
599cee73
PM
712}
713
c4a853d1 714sub unimport
6e9af7e4 715{
599cee73 716 shift;
6e9af7e4
PM
717
718 my $catmask ;
7fc874e8 719 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 720
d3a7d8c7 721 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 722 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
723 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
724 }
6e9af7e4 725
c91312d5
H
726 # append 'all' when implied (empty import list or after a lone "FATAL")
727 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
6e9af7e4
PM
728
729 foreach my $word ( @_ ) {
730 if ($word eq 'FATAL') {
c4a853d1 731 next;
6e9af7e4
PM
732 }
733 elsif ($catmask = $Bits{$word}) {
734 $mask &= ~($catmask | $DeadBits{$word} | $All);
735 }
736 else
737 { Croaker("Unknown warnings category '$word'")}
738 }
739
740 ${^WARNING_BITS} = $mask ;
599cee73
PM
741}
742
9df0f64f 743my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
744
96183d25 745sub MESSAGE () { 4 };
8787a747
NC
746sub FATAL () { 2 };
747sub NORMAL () { 1 };
748
7e6d00f8 749sub __chk
599cee73 750{
d3a7d8c7
GS
751 my $category ;
752 my $offset ;
7e6d00f8 753 my $isobj = 0 ;
8787a747 754 my $wanted = shift;
96183d25
NC
755 my $has_message = $wanted & MESSAGE;
756
757 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
758 my $sub = (caller 1)[3];
759 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
760 Croaker("Usage: $sub($syntax)");
761 }
762
763 my $message = pop if $has_message;
d3a7d8c7
GS
764
765 if (@_) {
766 # check the category supplied.
767 $category = shift ;
9df0f64f 768 if (my $type = ref $category) {
769 Croaker("not an object")
770 if exists $builtin_type{$type};
771 $category = $type;
7e6d00f8
PM
772 $isobj = 1 ;
773 }
d3a7d8c7 774 $offset = $Offsets{$category};
c3186b65 775 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
776 unless defined $offset;
777 }
778 else {
0ca4541c 779 $category = (caller(1))[0] ;
d3a7d8c7 780 $offset = $Offsets{$category};
c3186b65 781 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
782 unless defined $offset ;
783 }
784
f0a8fd68 785 my $i;
7e6d00f8
PM
786
787 if ($isobj) {
f0a8fd68
NC
788 my $pkg;
789 $i = 2;
7e6d00f8
PM
790 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
791 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
792 }
793 $i -= 2 ;
794 }
795 else {
4f527b71 796 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
797 }
798
7fc874e8
FC
799 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
800 # explicitly returns undef.
801 my(@callers_bitmask) = (caller($i))[9] ;
802 my $callers_bitmask =
803 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
8787a747
NC
804
805 my @results;
96183d25 806 foreach my $type (FATAL, NORMAL) {
8787a747
NC
807 next unless $wanted & $type;
808
809 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
810 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
811 }
96183d25
NC
812
813 # &enabled and &fatal_enabled
814 return $results[0] unless $has_message;
815
816 # &warnif, and the category is neither enabled as warning nor as fatal
817 return if $wanted == (NORMAL | FATAL | MESSAGE)
818 && !($results[0] || $results[1]);
819
820 require Carp;
821 Carp::croak($message) if $results[0];
822 # will always get here for &warn. will only get here for &warnif if the
823 # category is enabled
824 Carp::carp($message);
7e6d00f8
PM
825}
826
13781810
FR
827sub _mkMask
828{
829 my ($bit) = @_;
830 my $mask = "";
831
832 vec($mask, $bit, 1) = 1;
833 return $mask;
834}
835
5e7ad92a 836sub register_categories
13781810
FR
837{
838 my @names = @_;
839
840 for my $name (@names) {
841 if (! defined $Bits{$name}) {
842 $Bits{$name} = _mkMask($LAST_BIT);
843 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
844 $Offsets{$name} = $LAST_BIT ++;
845 foreach my $k (keys %Bits) {
846 vec($Bits{$k}, $LAST_BIT, 1) = 0;
847 }
848 $DeadBits{$name} = _mkMask($LAST_BIT);
849 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
850 }
851 }
852}
853
4f527b71 854sub _error_loc {
4dd71923 855 require Carp;
4f527b71 856 goto &Carp::short_error_loc; # don't introduce another stack frame
13781810 857}
4f527b71 858
7e6d00f8
PM
859sub enabled
860{
8787a747 861 return __chk(NORMAL, @_);
599cee73
PM
862}
863
ec983580
AR
864sub fatal_enabled
865{
8787a747 866 return __chk(FATAL, @_);
ec983580 867}
d3a7d8c7 868
e476b1b5
GS
869sub warn
870{
96183d25 871 return __chk(FATAL | MESSAGE, @_);
e476b1b5
GS
872}
873
7e6d00f8
PM
874sub warnif
875{
96183d25 876 return __chk(NORMAL | FATAL | MESSAGE, @_);
7e6d00f8 877}
0d658bf5 878
8787a747
NC
879# These are not part of any public interface, so we can delete them to save
880# space.
b9929960 881delete @warnings::{qw(NORMAL FATAL MESSAGE)};
8787a747 882
599cee73 8831;