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