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