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