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