This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
silence warning after "Fold join to const or stringify where possible"
[perl5.git] / lib / warnings.pm
CommitLineData
37442d52 1# -*- buffer-read-only: t -*-
38875929 2# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
78102347
NC
3# This file is built by regen/warnings.pl.
4# Any changes made here will be lost!
599cee73 5
4438c4b7 6package warnings;
599cee73 7
be16e595 8our $VERSION = '1.27';
f2c3e829
RGS
9
10# Verify that we're called correctly so that warnings will work.
11# see also strict.pm.
5108dc18 12unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
f2c3e829 13 my (undef, $f, $l) = caller;
5108dc18 14 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
f2c3e829 15}
0ca4541c 16
599cee73
PM
17=head1 NAME
18
4438c4b7 19warnings - Perl pragma to control optional warnings
599cee73
PM
20
21=head1 SYNOPSIS
22
4438c4b7
JH
23 use warnings;
24 no warnings;
599cee73 25
4438c4b7
JH
26 use warnings "all";
27 no warnings "all";
599cee73 28
d3a7d8c7
GS
29 use warnings::register;
30 if (warnings::enabled()) {
31 warnings::warn("some warning");
32 }
33
34 if (warnings::enabled("void")) {
e476b1b5
GS
35 warnings::warn("void", "some warning");
36 }
37
7e6d00f8
PM
38 if (warnings::enabled($object)) {
39 warnings::warn($object, "some warning");
40 }
41
721f911b
PM
42 warnings::warnif("some warning");
43 warnings::warnif("void", "some warning");
44 warnings::warnif($object, "some warning");
7e6d00f8 45
599cee73
PM
46=head1 DESCRIPTION
47
a7f2b7af
RS
48The C<warnings> pragma gives control over which warnings are enabled in
49which parts of a Perl program. It's a more flexible alternative for
50both the command line flag B<-w> and the equivalent Perl variable,
51C<$^W>.
fe2e802c 52
a7f2b7af
RS
53This pragma works just like the C<strict> pragma.
54This means that the scope of the warning pragma is limited to the
55enclosing block. It also means that the pragma setting will not
56leak across files (via C<use>, C<require> or C<do>). This allows
57authors to independently define the degree of warning checks that will
58be applied to their module.
599cee73 59
a7f2b7af
RS
60By default, optional warnings are disabled, so any legacy code that
61doesn't attempt to control the warnings will work unchanged.
62
63All warnings are enabled in a block by either of these:
64
65 use warnings;
66 use warnings 'all';
67
68Similarly all warnings are disabled in a block by either of these:
69
70 no warnings;
71 no warnings 'all';
72
73For example, consider the code below:
74
75 use warnings;
76 my @a;
77 {
78 no warnings;
79 my $b = @a[0];
80 }
81 my $c = @a[0];
82
83The code in the enclosing block has warnings enabled, but the inner
84block has them disabled. In this case that means the assignment to the
85scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]">
86warning, but the assignment to the scalar C<$b> will not.
87
88=head2 Default Warnings and Optional Warnings
89
90Before the introduction of lexical warnings, Perl had two classes of
91warnings: mandatory and optional.
92
93As its name suggests, if your code tripped a mandatory warning, you
94would get a warning whether you wanted it or not.
95For example, the code below would always produce an C<"isn't numeric">
96warning about the "2:".
97
98 my $a = "2:" + 3;
99
100With the introduction of lexical warnings, mandatory warnings now become
101I<default> warnings. The difference is that although the previously
102mandatory warnings are still enabled by default, they can then be
103subsequently enabled or disabled with the lexical warning pragma. For
104example, in the code below, an C<"isn't numeric"> warning will only
105be reported for the C<$a> variable.
106
107 my $a = "2:" + 3;
108 no warnings;
109 my $b = "2:" + 3;
110
111Note that neither the B<-w> flag or the C<$^W> can be used to
112disable/enable default warnings. They are still mandatory in this case.
113
114=head2 What's wrong with B<-w> and C<$^W>
115
116Although very useful, the big problem with using B<-w> on the command
117line to enable warnings is that it is all or nothing. Take the typical
118scenario when you are writing a Perl program. Parts of the code you
119will write yourself, but it's very likely that you will make use of
120pre-written Perl modules. If you use the B<-w> flag in this case, you
121end up enabling warnings in pieces of code that you haven't written.
122
123Similarly, using C<$^W> to either disable or enable blocks of code is
124fundamentally flawed. For a start, say you want to disable warnings in
125a block of code. You might expect this to be enough to do the trick:
126
127 {
128 local ($^W) = 0;
129 my $a =+ 2;
130 my $b; chop $b;
131 }
132
133When this code is run with the B<-w> flag, a warning will be produced
134for the C<$a> line: C<"Reversed += operator">.
135
136The problem is that Perl has both compile-time and run-time warnings. To
137disable compile-time warnings you need to rewrite the code like this:
138
139 {
140 BEGIN { $^W = 0 }
141 my $a =+ 2;
142 my $b; chop $b;
143 }
144
145The other big problem with C<$^W> is the way you can inadvertently
146change the warning setting in unexpected places in your code. For example,
147when the code below is run (without the B<-w> flag), the second call
148to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
149the first will not.
150
151 sub doit
152 {
153 my $b; chop $b;
154 }
155
156 doit();
157
158 {
159 local ($^W) = 1;
160 doit()
161 }
162
163This is a side-effect of C<$^W> being dynamically scoped.
164
165Lexical warnings get around these limitations by allowing finer control
166over where warnings can or can't be tripped.
167
168=head2 Controlling Warnings from the Command Line
169
170There are three Command Line flags that can be used to control when
171warnings are (or aren't) produced:
172
173=over 5
174
175=item B<-w>
176X<-w>
177
178This is the existing flag. If the lexical warnings pragma is B<not>
179used in any of you code, or any of the modules that you use, this flag
180will enable warnings everywhere. See L<Backward Compatibility> for
181details of how this flag interacts with lexical warnings.
182
183=item B<-W>
184X<-W>
185
186If the B<-W> flag is used on the command line, it will enable all warnings
187throughout the program regardless of whether warnings were disabled
188locally using C<no warnings> or C<$^W =0>.
189This includes all files that get
190included via C<use>, C<require> or C<do>.
191Think of it as the Perl equivalent of the "lint" command.
192
193=item B<-X>
194X<-X>
195
196Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
197
198=back
199
200=head2 Backward Compatibility
201
202If you are used to working with a version of Perl prior to the
203introduction of lexically scoped warnings, or have code that uses both
204lexical warnings and C<$^W>, this section will describe how they interact.
205
206How Lexical Warnings interact with B<-w>/C<$^W>:
207
208=over 5
209
210=item 1.
211
212If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
213control warnings is used and neither C<$^W> nor the C<warnings> pragma
214are used, then default warnings will be enabled and optional warnings
215disabled.
216This means that legacy code that doesn't attempt to control the warnings
217will work unchanged.
218
219=item 2.
220
221The B<-w> flag just sets the global C<$^W> variable as in 5.005. This
222means that any legacy code that currently relies on manipulating C<$^W>
223to control warning behavior will still work as is.
224
225=item 3.
226
227Apart from now being a boolean, the C<$^W> variable operates in exactly
228the same horrible uncontrolled global way, except that it cannot
229disable/enable default warnings.
230
231=item 4.
232
233If a piece of code is under the control of the C<warnings> pragma,
234both the C<$^W> variable and the B<-w> flag will be ignored for the
235scope of the lexical warning.
236
237=item 5.
238
239The only way to override a lexical warnings setting is with the B<-W>
240or B<-X> command line flags.
241
242=back
243
244The combined effect of 3 & 4 is that it will allow code which uses
245the C<warnings> pragma to control the warning behavior of $^W-type
246code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
247
248=head2 Category Hierarchy
249X<warning, categories>
250
251A hierarchy of "categories" have been defined to allow groups of warnings
252to be enabled/disabled in isolation.
253
254The current hierarchy is:
255
256 all -+
257 |
258 +- closure
259 |
260 +- deprecated
261 |
262 +- exiting
263 |
264 +- experimental --+
265 | |
266 | +- experimental::autoderef
267 | |
268 | +- experimental::lexical_subs
269 | |
270 | +- experimental::lexical_topic
271 | |
f438dbf0
FC
272 | +- experimental::lvalue_refs
273 | |
a7f2b7af
RS
274 | +- experimental::postderef
275 | |
276 | +- experimental::regex_sets
277 | |
278 | +- experimental::signatures
279 | |
280 | +- experimental::smartmatch
7ac92924
TC
281 | |
282 | +- experimental::win32_perlio
a7f2b7af
RS
283 |
284 +- glob
285 |
286 +- imprecision
287 |
288 +- io ------------+
289 | |
290 | +- closed
291 | |
292 | +- exec
293 | |
294 | +- layer
295 | |
296 | +- newline
297 | |
298 | +- pipe
299 | |
300 | +- syscalls
301 | |
302 | +- unopened
303 |
304 +- misc
305 |
3664866e
AB
306 +- missing
307 |
a7f2b7af
RS
308 +- numeric
309 |
310 +- once
311 |
312 +- overflow
313 |
314 +- pack
315 |
316 +- portable
317 |
318 +- recursion
319 |
320 +- redefine
321 |
4077a6bc
AB
322 +- redundant
323 |
a7f2b7af
RS
324 +- regexp
325 |
326 +- severe --------+
327 | |
328 | +- debugging
329 | |
330 | +- inplace
331 | |
332 | +- internal
333 | |
334 | +- malloc
335 |
336 +- signal
337 |
338 +- substr
339 |
340 +- syntax --------+
341 | |
342 | +- ambiguous
343 | |
344 | +- bareword
345 | |
346 | +- digit
347 | |
348 | +- illegalproto
349 | |
350 | +- parenthesis
351 | |
352 | +- precedence
353 | |
354 | +- printf
355 | |
356 | +- prototype
357 | |
358 | +- qw
359 | |
360 | +- reserved
361 | |
362 | +- semicolon
363 |
364 +- taint
365 |
366 +- threads
367 |
368 +- uninitialized
369 |
370 +- unpack
371 |
372 +- untie
373 |
374 +- utf8 ----------+
375 | |
376 | +- non_unicode
377 | |
378 | +- nonchar
379 | |
380 | +- surrogate
381 |
382 +- void
383
384Just like the "strict" pragma any of these categories can be combined
385
386 use warnings qw(void redefine);
387 no warnings qw(io syntax untie);
388
389Also like the "strict" pragma, if there is more than one instance of the
390C<warnings> pragma in a given scope the cumulative effect is additive.
391
392 use warnings qw(void); # only "void" warnings enabled
393 ...
394 use warnings qw(io); # only "void" & "io" warnings enabled
395 ...
396 no warnings qw(void); # only "io" warnings enabled
397
398To determine which category a specific warning has been assigned to see
399L<perldiag>.
400
401Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
402sub-category of the "syntax" category. It is now a top-level category
403in its own right.
404
3664866e
AB
405Note: Before 5.21.0, the "missing" lexical warnings category was
406internally defined to be the same as the "uninitialized" category. It
407is now a top-level category in its own right.
408
a7f2b7af
RS
409=head2 Fatal Warnings
410X<warning, fatal>
411
412The presence of the word "FATAL" in the category list will escalate any
413warnings detected from the categories specified in the lexical scope
414into fatal errors. In the code below, the use of C<time>, C<length>
415and C<join> can all produce a C<"Useless use of xxx in void context">
416warning.
417
418 use warnings;
419
420 time;
421
422 {
423 use warnings FATAL => qw(void);
424 length "abc";
425 }
426
427 join "", 1,2,3;
428
429 print "done\n";
430
431When run it produces this output
432
433 Useless use of time in void context at fatal line 3.
434 Useless use of length in void context at fatal line 7.
435
436The scope where C<length> is used has escalated the C<void> warnings
437category into a fatal error, so the program terminates immediately when it
438encounters the warning.
439
440To explicitly turn off a "FATAL" warning you just disable the warning
441it is associated with. So, for example, to disable the "void" warning
442in the example above, either of these will do the trick:
443
444 no warnings qw(void);
445 no warnings FATAL => qw(void);
446
447If you want to downgrade a warning that has been escalated into a fatal
448error back to a normal warning, you can use the "NONFATAL" keyword. For
449example, the code below will promote all warnings into fatal errors,
450except for those in the "syntax" category.
451
452 use warnings FATAL => 'all', NONFATAL => 'syntax';
453
454As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
455use:
456
457 use v5.20; # Perl 5.20 or greater is required for the following
458 use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';"
459
460If you want your program to be compatible with versions of Perl before
4615.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In
462previous versions of Perl, the behavior of the statements
463C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
464C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
465they included the C<< => 'all' >> portion. As of 5.20, they do.)
466
467B<NOTE:> Users of FATAL warnings, especially
468those using C<< FATAL => 'all' >>
469should be fully aware that they are risking future portability of their
470programs by doing so. Perl makes absolutely no commitments to not
471introduce new warnings, or warnings categories in the future, and indeed
472we explicitly reserve the right to do so. Code that may not warn now may
473warn in a future release of Perl if the Perl5 development team deems it
474in the best interests of the community to do so. Should code using FATAL
475warnings break due to the introduction of a new warning we will NOT
476consider it an incompatible change. Users of FATAL warnings should take
477special caution during upgrades to check to see if their code triggers
478any new warnings and should pay particular attention to the fine print of
479the documentation of the features they use to ensure they do not exploit
480features that are documented as risky, deprecated, or unspecified, or where
481the documentation says "so don't do that", or anything with the same sense
482and spirit. Use of such features in combination with FATAL warnings is
483ENTIRELY AT THE USER'S RISK.
484
485=head2 Reporting Warnings from a Module
486X<warning, reporting> X<warning, registering>
487
488The C<warnings> pragma provides a number of functions that are useful for
489module authors. These are used when you want to report a module-specific
490warning to a calling module has enabled warnings via the C<warnings>
491pragma.
492
493Consider the module C<MyMod::Abc> below.
494
495 package MyMod::Abc;
496
497 use warnings::register;
498
499 sub open {
500 my $path = shift;
501 if ($path !~ m#^/#) {
502 warnings::warn("changing relative path to /var/abc")
503 if warnings::enabled();
504 $path = "/var/abc/$path";
505 }
506 }
507
508 1;
509
510The call to C<warnings::register> will create a new warnings category
511called "MyMod::Abc", i.e. the new category name matches the current
512package name. The C<open> function in the module will display a warning
513message if it gets given a relative path as a parameter. This warnings
514will only be displayed if the code that uses C<MyMod::Abc> has actually
515enabled them with the C<warnings> pragma like below.
516
517 use MyMod::Abc;
518 use warnings 'MyMod::Abc';
519 ...
520 abc::open("../fred.txt");
521
522It is also possible to test whether the pre-defined warnings categories are
523set in the calling module with the C<warnings::enabled> function. Consider
524this snippet of code:
525
526 package MyMod::Abc;
527
528 sub open {
529 warnings::warnif("deprecated",
530 "open is deprecated, use new instead");
531 new(@_);
532 }
533
534 sub new
535 ...
536 1;
537
538The function C<open> has been deprecated, so code has been included to
539display a warning message whenever the calling module has (at least) the
540"deprecated" warnings category enabled. Something like this, say.
541
542 use warnings 'deprecated';
543 use MyMod::Abc;
544 ...
545 MyMod::Abc::open($filename);
546
547Either the C<warnings::warn> or C<warnings::warnif> function should be
548used to actually display the warnings message. This is because they can
549make use of the feature that allows warnings to be escalated into fatal
550errors. So in this case
551
552 use MyMod::Abc;
553 use warnings FATAL => 'MyMod::Abc';
554 ...
555 MyMod::Abc::open('../fred.txt');
556
557the C<warnings::warnif> function will detect this and die after
558displaying the warning message.
559
560The three warnings functions, C<warnings::warn>, C<warnings::warnif>
561and C<warnings::enabled> can optionally take an object reference in place
562of a category name. In this case the functions will use the class name
563of the object as the warnings category.
564
565Consider this example:
566
567 package Original;
568
569 no warnings;
570 use warnings::register;
571
572 sub new
573 {
574 my $class = shift;
575 bless [], $class;
576 }
577
578 sub check
579 {
580 my $self = shift;
581 my $value = shift;
582
583 if ($value % 2 && warnings::enabled($self))
584 { warnings::warn($self, "Odd numbers are unsafe") }
585 }
586
587 sub doit
588 {
589 my $self = shift;
590 my $value = shift;
591 $self->check($value);
592 # ...
593 }
594
595 1;
596
597 package Derived;
598
599 use warnings::register;
600 use Original;
601 our @ISA = qw( Original );
602 sub new
603 {
604 my $class = shift;
605 bless [], $class;
606 }
607
608
609 1;
610
611The code below makes use of both modules, but it only enables warnings from
612C<Derived>.
613
614 use Original;
615 use Derived;
616 use warnings 'Derived';
617 my $a = Original->new();
618 $a->doit(1);
619 my $b = Derived->new();
620 $a->doit(1);
621
622When this code is run only the C<Derived> object, C<$b>, will generate
623a warning.
624
625 Odd numbers are unsafe at main.pl line 7
626
627Notice also that the warning is reported at the line where the object is first
628used.
629
630When registering new categories of warning, you can supply more names to
631warnings::register like this:
632
633 package MyModule;
634 use warnings::register qw(format precision);
635
636 ...
637
638 warnings::warnif('MyModule::format', '...');
639
640=head1 FUNCTIONS
e476b1b5
GS
641
642=over 4
643
d3a7d8c7
GS
644=item use warnings::register
645
7e6d00f8
PM
646Creates a new warnings category with the same name as the package where
647the call to the pragma is used.
648
649=item warnings::enabled()
650
651Use the warnings category with the same name as the current package.
652
653Return TRUE if that warnings category is enabled in the calling module.
654Otherwise returns FALSE.
655
656=item warnings::enabled($category)
657
658Return TRUE if the warnings category, C<$category>, is enabled in the
659calling module.
660Otherwise returns FALSE.
661
662=item warnings::enabled($object)
663
664Use the name of the class for the object reference, C<$object>, as the
665warnings category.
666
667Return TRUE if that warnings category is enabled in the first scope
668where the object is used.
669Otherwise returns FALSE.
670
789c4615
RGS
671=item warnings::fatal_enabled()
672
673Return TRUE if the warnings category with the same name as the current
674package has been set to FATAL in the calling module.
675Otherwise returns FALSE.
676
677=item warnings::fatal_enabled($category)
678
679Return TRUE if the warnings category C<$category> has been set to FATAL in
680the calling module.
681Otherwise returns FALSE.
682
683=item warnings::fatal_enabled($object)
684
685Use the name of the class for the object reference, C<$object>, as the
686warnings category.
687
688Return TRUE if that warnings category has been set to FATAL in the first
689scope where the object is used.
690Otherwise returns FALSE.
691
7e6d00f8
PM
692=item warnings::warn($message)
693
694Print C<$message> to STDERR.
695
696Use the warnings category with the same name as the current package.
697
698If that warnings category has been set to "FATAL" in the calling module
699then die. Otherwise return.
700
701=item warnings::warn($category, $message)
702
703Print C<$message> to STDERR.
704
705If the warnings category, C<$category>, has been set to "FATAL" in the
706calling module then die. Otherwise return.
e476b1b5 707
7e6d00f8 708=item warnings::warn($object, $message)
e476b1b5 709
7e6d00f8 710Print C<$message> to STDERR.
e476b1b5 711
7e6d00f8
PM
712Use the name of the class for the object reference, C<$object>, as the
713warnings category.
d3a7d8c7 714
7e6d00f8
PM
715If that warnings category has been set to "FATAL" in the scope where C<$object>
716is first used then die. Otherwise return.
599cee73 717
e476b1b5 718
7e6d00f8
PM
719=item warnings::warnif($message)
720
721Equivalent to:
722
723 if (warnings::enabled())
724 { warnings::warn($message) }
725
726=item warnings::warnif($category, $message)
727
728Equivalent to:
729
730 if (warnings::enabled($category))
731 { warnings::warn($category, $message) }
732
733=item warnings::warnif($object, $message)
734
735Equivalent to:
736
737 if (warnings::enabled($object))
738 { warnings::warn($object, $message) }
d3a7d8c7 739
5e7ad92a 740=item warnings::register_categories(@names)
572bfd36
RS
741
742This registers warning categories for the given names and is primarily for
a7f2b7af 743use by the warnings::register pragma.
572bfd36 744
e476b1b5
GS
745=back
746
a7f2b7af 747See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.
599cee73
PM
748
749=cut
750
53c33732 751our %Offsets = (
0d658bf5
PM
752
753 # Warnings Categories added in Perl 5.008
754
d3a7d8c7 755 'all' => 0,
3eae5ce4 756 'closure' => 2,
12bcd1a6
PM
757 'deprecated' => 4,
758 'exiting' => 6,
759 'glob' => 8,
760 'io' => 10,
761 'closed' => 12,
762 'exec' => 14,
99ef548b
PM
763 'layer' => 16,
764 'newline' => 18,
765 'pipe' => 20,
766 'unopened' => 22,
767 'misc' => 24,
768 'numeric' => 26,
769 'once' => 28,
770 'overflow' => 30,
771 'pack' => 32,
772 'portable' => 34,
773 'recursion' => 36,
774 'redefine' => 38,
775 'regexp' => 40,
776 'severe' => 42,
777 'debugging' => 44,
778 'inplace' => 46,
779 'internal' => 48,
780 'malloc' => 50,
781 'signal' => 52,
782 'substr' => 54,
783 'syntax' => 56,
784 'ambiguous' => 58,
785 'bareword' => 60,
786 'digit' => 62,
787 'parenthesis' => 64,
788 'precedence' => 66,
789 'printf' => 68,
790 'prototype' => 70,
791 'qw' => 72,
792 'reserved' => 74,
793 'semicolon' => 76,
794 'taint' => 78,
38875929
DM
795 'threads' => 80,
796 'uninitialized' => 82,
797 'unpack' => 84,
798 'untie' => 86,
799 'utf8' => 88,
800 'void' => 90,
b88df990
NC
801
802 # Warnings Categories added in Perl 5.011
803
804 'imprecision' => 92,
197afce1 805 'illegalproto' => 94,
8457b38f
KW
806
807 # Warnings Categories added in Perl 5.013
808
809 'non_unicode' => 96,
810 'nonchar' => 98,
811 'surrogate' => 100,
6f87cb12
FC
812
813 # Warnings Categories added in Perl 5.017
814
815 'experimental' => 102,
f1d34ca8 816 'experimental::lexical_subs'=> 104,
4055dbce
RS
817 'experimental::lexical_topic'=> 106,
818 'experimental::regex_sets'=> 108,
0f539b13 819 'experimental::smartmatch'=> 110,
c8028aa6
TC
820
821 # Warnings Categories added in Perl 5.019
822
d401967c 823 'experimental::autoderef'=> 112,
0953b66b 824 'experimental::postderef'=> 114,
30d9c59b
Z
825 'experimental::signatures'=> 116,
826 'syscalls' => 118,
7ac92924
TC
827
828 # Warnings Categories added in Perl 5.021
829
f438dbf0
FC
830 'experimental::lvalue_refs'=> 120,
831 'experimental::win32_perlio'=> 122,
832 'missing' => 124,
833 'redundant' => 126,
d3a7d8c7
GS
834 );
835
53c33732 836our %Bits = (
f438dbf0 837 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..63]
7ac92924
TC
838 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
839 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
840 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
841 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
842 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
843 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
844 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
845 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
846 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
f438dbf0 847 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x15\x05", # [51..58,60,61]
7ac92924
TC
848 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [56]
849 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [52]
850 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [53]
f438dbf0 851 'experimental::lvalue_refs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [60]
7ac92924
TC
852 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [57]
853 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [54]
854 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [58]
855 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [55]
f438dbf0 856 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [61]
7ac92924
TC
857 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
858 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [47]
859 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [46]
860 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
861 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
862 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [5..11,59]
863 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
864 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
865 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
f438dbf0 866 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [62]
7ac92924
TC
867 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
868 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [48]
869 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [49]
870 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
871 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
872 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
873 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
874 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [32]
875 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
876 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
877 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [33]
878 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [34]
879 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [35]
880 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [36]
881 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
882 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
f438dbf0 883 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [63]
7ac92924
TC
884 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
885 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [37]
886 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [38]
887 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
888 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
889 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
890 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [50]
891 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00\x00", # [28..38,47]
892 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [59]
893 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [39]
894 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [40]
895 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [41]
896 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
897 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [42]
898 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [43]
899 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00\x00", # [44,48..50]
900 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [45]
599cee73
PM
901 );
902
53c33732 903our %DeadBits = (
f438dbf0 904 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..63]
7ac92924
TC
905 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
906 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
907 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
908 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
909 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
910 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
911 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
912 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
913 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
f438dbf0 914 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x2a\x0a", # [51..58,60,61]
7ac92924
TC
915 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [56]
916 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [52]
917 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [53]
f438dbf0 918 'experimental::lvalue_refs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [60]
7ac92924
TC
919 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [57]
920 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [54]
921 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [58]
922 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [55]
f438dbf0 923 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [61]
7ac92924
TC
924 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
925 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [47]
926 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [46]
927 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
928 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
929 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [5..11,59]
930 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
931 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
932 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
f438dbf0 933 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [62]
7ac92924
TC
934 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
935 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [48]
936 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [49]
937 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
938 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
939 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
940 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
941 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [32]
942 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
943 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
944 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [33]
945 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [34]
946 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [35]
947 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [36]
948 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
949 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
f438dbf0 950 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [63]
7ac92924
TC
951 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
952 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [37]
953 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [38]
954 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
955 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
956 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
957 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [50]
958 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00\x00", # [28..38,47]
959 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [59]
960 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [39]
961 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [40]
962 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [41]
963 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
964 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [42]
965 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [43]
966 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00\x00", # [44,48..50]
967 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [45]
599cee73
PM
968 );
969
7ac92924 970$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
f438dbf0
FC
971$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x05", # [2,56,52,53,60,57,54,58,55,61,4,22,23,25]
972$LAST_BIT = 128 ;
7ac92924 973$BYTES = 16 ;
d3a7d8c7
GS
974
975$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73 976
c3186b65
PM
977sub Croaker
978{
4dd71923 979 require Carp; # this initializes %CarpInternal
dbab294c 980 local $Carp::CarpInternal{'warnings'};
c3186b65 981 delete $Carp::CarpInternal{'warnings'};
8becbb3b 982 Carp::croak(@_);
c3186b65
PM
983}
984
4c02ac93
NC
985sub _bits {
986 my $mask = shift ;
599cee73
PM
987 my $catmask ;
988 my $fatal = 0 ;
6e9af7e4
PM
989 my $no_fatal = 0 ;
990
991 foreach my $word ( @_ ) {
992 if ($word eq 'FATAL') {
327afb7f 993 $fatal = 1;
6e9af7e4
PM
994 $no_fatal = 0;
995 }
996 elsif ($word eq 'NONFATAL') {
997 $fatal = 0;
998 $no_fatal = 1;
327afb7f 999 }
d3a7d8c7
GS
1000 elsif ($catmask = $Bits{$word}) {
1001 $mask |= $catmask ;
1002 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 1003 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 1004 }
d3a7d8c7 1005 else
c3186b65 1006 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
1007 }
1008
1009 return $mask ;
1010}
1011
4c02ac93
NC
1012sub bits
1013{
1014 # called from B::Deparse.pm
1015 push @_, 'all' unless @_ ;
1016 return _bits(undef, @_) ;
1017}
1018
a7f2b7af 1019sub import
6e9af7e4 1020{
599cee73 1021 shift;
6e9af7e4 1022
7fc874e8 1023 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 1024
f1f33818
PM
1025 if (vec($mask, $Offsets{'all'}, 1)) {
1026 $mask |= $Bits{'all'} ;
1027 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1028 }
c91312d5
H
1029
1030 # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
1031 push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
a7f2b7af 1032
4c02ac93
NC
1033 # Empty @_ is equivalent to @_ = 'all' ;
1034 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
599cee73
PM
1035}
1036
a7f2b7af 1037sub unimport
6e9af7e4 1038{
599cee73 1039 shift;
6e9af7e4
PM
1040
1041 my $catmask ;
7fc874e8 1042 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 1043
d3a7d8c7 1044 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 1045 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
1046 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1047 }
6e9af7e4 1048
c91312d5
H
1049 # append 'all' when implied (empty import list or after a lone "FATAL")
1050 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
6e9af7e4
PM
1051
1052 foreach my $word ( @_ ) {
1053 if ($word eq 'FATAL') {
a7f2b7af 1054 next;
6e9af7e4
PM
1055 }
1056 elsif ($catmask = $Bits{$word}) {
1057 $mask &= ~($catmask | $DeadBits{$word} | $All);
1058 }
1059 else
1060 { Croaker("Unknown warnings category '$word'")}
1061 }
1062
1063 ${^WARNING_BITS} = $mask ;
599cee73
PM
1064}
1065
9df0f64f 1066my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
1067
96183d25 1068sub MESSAGE () { 4 };
8787a747
NC
1069sub FATAL () { 2 };
1070sub NORMAL () { 1 };
1071
7e6d00f8 1072sub __chk
599cee73 1073{
d3a7d8c7
GS
1074 my $category ;
1075 my $offset ;
7e6d00f8 1076 my $isobj = 0 ;
8787a747 1077 my $wanted = shift;
96183d25
NC
1078 my $has_message = $wanted & MESSAGE;
1079
1080 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
1081 my $sub = (caller 1)[3];
1082 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
1083 Croaker("Usage: $sub($syntax)");
1084 }
1085
1086 my $message = pop if $has_message;
d3a7d8c7
GS
1087
1088 if (@_) {
1089 # check the category supplied.
1090 $category = shift ;
9df0f64f 1091 if (my $type = ref $category) {
1092 Croaker("not an object")
1093 if exists $builtin_type{$type};
1094 $category = $type;
7e6d00f8
PM
1095 $isobj = 1 ;
1096 }
d3a7d8c7 1097 $offset = $Offsets{$category};
c3186b65 1098 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
1099 unless defined $offset;
1100 }
1101 else {
0ca4541c 1102 $category = (caller(1))[0] ;
d3a7d8c7 1103 $offset = $Offsets{$category};
c3186b65 1104 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
1105 unless defined $offset ;
1106 }
1107
f0a8fd68 1108 my $i;
7e6d00f8
PM
1109
1110 if ($isobj) {
f0a8fd68
NC
1111 my $pkg;
1112 $i = 2;
7e6d00f8
PM
1113 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
1114 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
1115 }
1116 $i -= 2 ;
1117 }
1118 else {
4f527b71 1119 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
1120 }
1121
7fc874e8
FC
1122 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
1123 # explicitly returns undef.
1124 my(@callers_bitmask) = (caller($i))[9] ;
1125 my $callers_bitmask =
1126 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
8787a747
NC
1127
1128 my @results;
96183d25 1129 foreach my $type (FATAL, NORMAL) {
8787a747
NC
1130 next unless $wanted & $type;
1131
1132 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
1133 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
1134 }
96183d25
NC
1135
1136 # &enabled and &fatal_enabled
1137 return $results[0] unless $has_message;
1138
1139 # &warnif, and the category is neither enabled as warning nor as fatal
1140 return if $wanted == (NORMAL | FATAL | MESSAGE)
1141 && !($results[0] || $results[1]);
1142
1143 require Carp;
1144 Carp::croak($message) if $results[0];
1145 # will always get here for &warn. will only get here for &warnif if the
1146 # category is enabled
1147 Carp::carp($message);
7e6d00f8
PM
1148}
1149
572bfd36
RS
1150sub _mkMask
1151{
1152 my ($bit) = @_;
1153 my $mask = "";
1154
1155 vec($mask, $bit, 1) = 1;
1156 return $mask;
1157}
1158
5e7ad92a 1159sub register_categories
572bfd36
RS
1160{
1161 my @names = @_;
1162
1163 for my $name (@names) {
1164 if (! defined $Bits{$name}) {
1165 $Bits{$name} = _mkMask($LAST_BIT);
1166 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
1167 $Offsets{$name} = $LAST_BIT ++;
1168 foreach my $k (keys %Bits) {
1169 vec($Bits{$k}, $LAST_BIT, 1) = 0;
1170 }
1171 $DeadBits{$name} = _mkMask($LAST_BIT);
1172 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
1173 }
1174 }
1175}
1176
4f527b71 1177sub _error_loc {
4dd71923 1178 require Carp;
4f527b71 1179 goto &Carp::short_error_loc; # don't introduce another stack frame
13781810 1180}
4f527b71 1181
7e6d00f8
PM
1182sub enabled
1183{
8787a747 1184 return __chk(NORMAL, @_);
599cee73
PM
1185}
1186
789c4615
RGS
1187sub fatal_enabled
1188{
8787a747 1189 return __chk(FATAL, @_);
789c4615 1190}
d3a7d8c7 1191
e476b1b5
GS
1192sub warn
1193{
96183d25 1194 return __chk(FATAL | MESSAGE, @_);
e476b1b5
GS
1195}
1196
7e6d00f8
PM
1197sub warnif
1198{
96183d25 1199 return __chk(NORMAL | FATAL | MESSAGE, @_);
7e6d00f8 1200}
0d658bf5 1201
8787a747
NC
1202# These are not part of any public interface, so we can delete them to save
1203# space.
b9929960 1204delete @warnings::{qw(NORMAL FATAL MESSAGE)};
8787a747 1205
599cee73 12061;
ce716c52 1207
37442d52 1208# ex: set ro: