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