This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add experimental::lvalue_refs warnings category
[perl5.git] / lib / warnings.pm
1 # -*- buffer-read-only: t -*-
2 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
3 # This file is built by regen/warnings.pl.
4 # Any changes made here will be lost!
5
6 package warnings;
7
8 our $VERSION = '1.26';
9
10 # Verify that we're called correctly so that warnings will work.
11 # see also strict.pm.
12 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
13     my (undef, $f, $l) = caller;
14     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
15 }
16
17 =head1 NAME
18
19 warnings - Perl pragma to control optional warnings
20
21 =head1 SYNOPSIS
22
23     use warnings;
24     no warnings;
25
26     use warnings "all";
27     no warnings "all";
28
29     use warnings::register;
30     if (warnings::enabled()) {
31         warnings::warn("some warning");
32     }
33
34     if (warnings::enabled("void")) {
35         warnings::warn("void", "some warning");
36     }
37
38     if (warnings::enabled($object)) {
39         warnings::warn($object, "some warning");
40     }
41
42     warnings::warnif("some warning");
43     warnings::warnif("void", "some warning");
44     warnings::warnif($object, "some warning");
45
46 =head1 DESCRIPTION
47
48 The C<warnings> pragma gives control over which warnings are enabled in
49 which parts of a Perl program.  It's a more flexible alternative for
50 both the command line flag B<-w> and the equivalent Perl variable,
51 C<$^W>.
52
53 This pragma works just like the C<strict> pragma.
54 This means that the scope of the warning pragma is limited to the
55 enclosing block.  It also means that the pragma setting will not
56 leak across files (via C<use>, C<require> or C<do>).  This allows
57 authors to independently define the degree of warning checks that will
58 be applied to their module.
59
60 By default, optional warnings are disabled, so any legacy code that
61 doesn't attempt to control the warnings will work unchanged.
62
63 All warnings are enabled in a block by either of these:
64
65     use warnings;
66     use warnings 'all';
67
68 Similarly all warnings are disabled in a block by either of these:
69
70     no warnings;
71     no warnings 'all';
72
73 For 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
83 The code in the enclosing block has warnings enabled, but the inner
84 block has them disabled.  In this case that means the assignment to the
85 scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]">
86 warning, but the assignment to the scalar C<$b> will not.
87
88 =head2 Default Warnings and Optional Warnings
89
90 Before the introduction of lexical warnings, Perl had two classes of
91 warnings: mandatory and optional. 
92
93 As its name suggests, if your code tripped a mandatory warning, you
94 would get a warning whether you wanted it or not.
95 For example, the code below would always produce an C<"isn't numeric">
96 warning about the "2:".
97
98     my $a = "2:" + 3;
99
100 With the introduction of lexical warnings, mandatory warnings now become
101 I<default> warnings.  The difference is that although the previously
102 mandatory warnings are still enabled by default, they can then be
103 subsequently enabled or disabled with the lexical warning pragma.  For
104 example, in the code below, an C<"isn't numeric"> warning will only
105 be reported for the C<$a> variable.
106
107     my $a = "2:" + 3;
108     no warnings;
109     my $b = "2:" + 3;
110
111 Note that neither the B<-w> flag or the C<$^W> can be used to
112 disable/enable default warnings.  They are still mandatory in this case.
113
114 =head2 What's wrong with B<-w> and C<$^W>
115
116 Although very useful, the big problem with using B<-w> on the command
117 line to enable warnings is that it is all or nothing.  Take the typical
118 scenario when you are writing a Perl program.  Parts of the code you
119 will write yourself, but it's very likely that you will make use of
120 pre-written Perl modules.  If you use the B<-w> flag in this case, you
121 end up enabling warnings in pieces of code that you haven't written.
122
123 Similarly, using C<$^W> to either disable or enable blocks of code is
124 fundamentally flawed.  For a start, say you want to disable warnings in
125 a 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
133 When this code is run with the B<-w> flag, a warning will be produced
134 for the C<$a> line:  C<"Reversed += operator">.
135
136 The problem is that Perl has both compile-time and run-time warnings.  To
137 disable 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
145 The other big problem with C<$^W> is the way you can inadvertently
146 change the warning setting in unexpected places in your code.  For example,
147 when the code below is run (without the B<-w> flag), the second call
148 to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
149 the 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
163 This is a side-effect of C<$^W> being dynamically scoped.
164
165 Lexical warnings get around these limitations by allowing finer control
166 over where warnings can or can't be tripped.
167
168 =head2 Controlling Warnings from the Command Line
169
170 There are three Command Line flags that can be used to control when
171 warnings are (or aren't) produced:
172
173 =over 5
174
175 =item B<-w>
176 X<-w>
177
178 This is  the existing flag.  If the lexical warnings pragma is B<not>
179 used in any of you code, or any of the modules that you use, this flag
180 will enable warnings everywhere.  See L<Backward Compatibility> for
181 details of how this flag interacts with lexical warnings.
182
183 =item B<-W>
184 X<-W>
185
186 If the B<-W> flag is used on the command line, it will enable all warnings
187 throughout the program regardless of whether warnings were disabled
188 locally using C<no warnings> or C<$^W =0>.
189 This includes all files that get
190 included via C<use>, C<require> or C<do>.
191 Think of it as the Perl equivalent of the "lint" command.
192
193 =item B<-X>
194 X<-X>
195
196 Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
197
198 =back
199
200 =head2 Backward Compatibility
201
202 If you are used to working with a version of Perl prior to the
203 introduction of lexically scoped warnings, or have code that uses both
204 lexical warnings and C<$^W>, this section will describe how they interact.
205
206 How Lexical Warnings interact with B<-w>/C<$^W>:
207
208 =over 5
209
210 =item 1.
211
212 If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
213 control warnings is used and neither C<$^W> nor the C<warnings> pragma
214 are used, then default warnings will be enabled and optional warnings
215 disabled.
216 This means that legacy code that doesn't attempt to control the warnings
217 will work unchanged.
218
219 =item 2.
220
221 The B<-w> flag just sets the global C<$^W> variable as in 5.005.  This
222 means that any legacy code that currently relies on manipulating C<$^W>
223 to control warning behavior will still work as is. 
224
225 =item 3.
226
227 Apart from now being a boolean, the C<$^W> variable operates in exactly
228 the same horrible uncontrolled global way, except that it cannot
229 disable/enable default warnings.
230
231 =item 4.
232
233 If a piece of code is under the control of the C<warnings> pragma,
234 both the C<$^W> variable and the B<-w> flag will be ignored for the
235 scope of the lexical warning.
236
237 =item 5.
238
239 The only way to override a lexical warnings setting is with the B<-W>
240 or B<-X> command line flags.
241
242 =back
243
244 The combined effect of 3 & 4 is that it will allow code which uses
245 the C<warnings> pragma to control the warning behavior of $^W-type
246 code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
247
248 =head2 Category Hierarchy
249 X<warning, categories>
250
251 A hierarchy of "categories" have been defined to allow groups of warnings
252 to be enabled/disabled in isolation.
253
254 The 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          |                 |
272          |                 +- experimental::lvalue_refs
273          |                 |
274          |                 +- experimental::postderef
275          |                 |
276          |                 +- experimental::regex_sets
277          |                 |
278          |                 +- experimental::signatures
279          |                 |
280          |                 +- experimental::smartmatch
281          |                 |
282          |                 +- experimental::win32_perlio
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          |
306          +- missing
307          |
308          +- numeric
309          |
310          +- once
311          |
312          +- overflow
313          |
314          +- pack
315          |
316          +- portable
317          |
318          +- recursion
319          |
320          +- redefine
321          |
322          +- redundant
323          |
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
384 Just 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
389 Also like the "strict" pragma, if there is more than one instance of the
390 C<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
398 To determine which category a specific warning has been assigned to see
399 L<perldiag>.
400
401 Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
402 sub-category of the "syntax" category.  It is now a top-level category
403 in its own right.
404
405 Note: Before 5.21.0, the "missing" lexical warnings category was
406 internally defined to be the same as the "uninitialized" category. It
407 is now a top-level category in its own right.
408
409 =head2 Fatal Warnings
410 X<warning, fatal>
411
412 The presence of the word "FATAL" in the category list will escalate any
413 warnings detected from the categories specified in the lexical scope
414 into fatal errors.  In the code below, the use of C<time>, C<length>
415 and C<join> can all produce a C<"Useless use of xxx in void context">
416 warning.
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
431 When 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
436 The scope where C<length> is used has escalated the C<void> warnings
437 category into a fatal error, so the program terminates immediately when it
438 encounters the warning.
439
440 To explicitly turn off a "FATAL" warning you just disable the warning
441 it is associated with.  So, for example, to disable the "void" warning
442 in the example above, either of these will do the trick:
443
444     no warnings qw(void);
445     no warnings FATAL => qw(void);
446
447 If you want to downgrade a warning that has been escalated into a fatal
448 error back to a normal warning, you can use the "NONFATAL" keyword.  For
449 example, the code below will promote all warnings into fatal errors,
450 except for those in the "syntax" category.
451
452     use warnings FATAL => 'all', NONFATAL => 'syntax';
453
454 As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
455 use:
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
460 If you want your program to be compatible with versions of Perl before
461 5.20, you must use C<< use warnings FATAL => 'all'; >> instead.  (In
462 previous versions of Perl, the behavior of the statements
463 C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
464 C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
465 they included the C<< => 'all' >> portion.  As of 5.20, they do.)
466
467 B<NOTE:> Users of FATAL warnings, especially
468 those using C<< FATAL => 'all' >>
469 should be fully aware that they are risking future portability of their
470 programs by doing so.  Perl makes absolutely no commitments to not
471 introduce new warnings, or warnings categories in the future, and indeed
472 we explicitly reserve the right to do so.  Code that may not warn now may
473 warn in a future release of Perl if the Perl5 development team deems it
474 in the best interests of the community to do so.  Should code using FATAL
475 warnings break due to the introduction of a new warning we will NOT
476 consider it an incompatible change.  Users of FATAL warnings should take
477 special caution during upgrades to check to see if their code triggers
478 any new warnings and should pay particular attention to the fine print of
479 the documentation of the features they use to ensure they do not exploit
480 features that are documented as risky, deprecated, or unspecified, or where
481 the documentation says "so don't do that", or anything with the same sense
482 and spirit.  Use of such features in combination with FATAL warnings is
483 ENTIRELY AT THE USER'S RISK.
484
485 =head2 Reporting Warnings from a Module
486 X<warning, reporting> X<warning, registering>
487
488 The C<warnings> pragma provides a number of functions that are useful for
489 module authors.  These are used when you want to report a module-specific
490 warning to a calling module has enabled warnings via the C<warnings>
491 pragma.
492
493 Consider 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
510 The call to C<warnings::register> will create a new warnings category
511 called "MyMod::Abc", i.e. the new category name matches the current
512 package name.  The C<open> function in the module will display a warning
513 message if it gets given a relative path as a parameter.  This warnings
514 will only be displayed if the code that uses C<MyMod::Abc> has actually
515 enabled 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
522 It is also possible to test whether the pre-defined warnings categories are
523 set in the calling module with the C<warnings::enabled> function.  Consider
524 this 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
538 The function C<open> has been deprecated, so code has been included to
539 display 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
547 Either the C<warnings::warn> or C<warnings::warnif> function should be
548 used to actually display the warnings message.  This is because they can
549 make use of the feature that allows warnings to be escalated into fatal
550 errors.  So in this case
551
552     use MyMod::Abc;
553     use warnings FATAL => 'MyMod::Abc';
554     ...
555     MyMod::Abc::open('../fred.txt');
556
557 the C<warnings::warnif> function will detect this and die after
558 displaying the warning message.
559
560 The three warnings functions, C<warnings::warn>, C<warnings::warnif>
561 and C<warnings::enabled> can optionally take an object reference in place
562 of a category name.  In this case the functions will use the class name
563 of the object as the warnings category.
564
565 Consider 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
611 The code below makes use of both modules, but it only enables warnings from 
612 C<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
622 When this code is run only the C<Derived> object, C<$b>, will generate
623 a warning. 
624
625     Odd numbers are unsafe at main.pl line 7
626
627 Notice also that the warning is reported at the line where the object is first
628 used.
629
630 When registering new categories of warning, you can supply more names to
631 warnings::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
641
642 =over 4
643
644 =item use warnings::register
645
646 Creates a new warnings category with the same name as the package where
647 the call to the pragma is used.
648
649 =item warnings::enabled()
650
651 Use the warnings category with the same name as the current package.
652
653 Return TRUE if that warnings category is enabled in the calling module.
654 Otherwise returns FALSE.
655
656 =item warnings::enabled($category)
657
658 Return TRUE if the warnings category, C<$category>, is enabled in the
659 calling module.
660 Otherwise returns FALSE.
661
662 =item warnings::enabled($object)
663
664 Use the name of the class for the object reference, C<$object>, as the
665 warnings category.
666
667 Return TRUE if that warnings category is enabled in the first scope
668 where the object is used.
669 Otherwise returns FALSE.
670
671 =item warnings::fatal_enabled()
672
673 Return TRUE if the warnings category with the same name as the current
674 package has been set to FATAL in the calling module.
675 Otherwise returns FALSE.
676
677 =item warnings::fatal_enabled($category)
678
679 Return TRUE if the warnings category C<$category> has been set to FATAL in
680 the calling module.
681 Otherwise returns FALSE.
682
683 =item warnings::fatal_enabled($object)
684
685 Use the name of the class for the object reference, C<$object>, as the
686 warnings category.
687
688 Return TRUE if that warnings category has been set to FATAL in the first
689 scope where the object is used.
690 Otherwise returns FALSE.
691
692 =item warnings::warn($message)
693
694 Print C<$message> to STDERR.
695
696 Use the warnings category with the same name as the current package.
697
698 If that warnings category has been set to "FATAL" in the calling module
699 then die. Otherwise return.
700
701 =item warnings::warn($category, $message)
702
703 Print C<$message> to STDERR.
704
705 If the warnings category, C<$category>, has been set to "FATAL" in the
706 calling module then die. Otherwise return.
707
708 =item warnings::warn($object, $message)
709
710 Print C<$message> to STDERR.
711
712 Use the name of the class for the object reference, C<$object>, as the
713 warnings category.
714
715 If that warnings category has been set to "FATAL" in the scope where C<$object>
716 is first used then die. Otherwise return.
717
718
719 =item warnings::warnif($message)
720
721 Equivalent to:
722
723     if (warnings::enabled())
724       { warnings::warn($message) }
725
726 =item warnings::warnif($category, $message)
727
728 Equivalent to:
729
730     if (warnings::enabled($category))
731       { warnings::warn($category, $message) }
732
733 =item warnings::warnif($object, $message)
734
735 Equivalent to:
736
737     if (warnings::enabled($object))
738       { warnings::warn($object, $message) }
739
740 =item warnings::register_categories(@names)
741
742 This registers warning categories for the given names and is primarily for
743 use by the warnings::register pragma.
744
745 =back
746
747 See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.
748
749 =cut
750
751 our %Offsets = (
752
753     # Warnings Categories added in Perl 5.008
754
755     'all'               => 0,
756     'closure'           => 2,
757     'deprecated'        => 4,
758     'exiting'           => 6,
759     'glob'              => 8,
760     'io'                => 10,
761     'closed'            => 12,
762     'exec'              => 14,
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,
795     'threads'           => 80,
796     'uninitialized'     => 82,
797     'unpack'            => 84,
798     'untie'             => 86,
799     'utf8'              => 88,
800     'void'              => 90,
801
802     # Warnings Categories added in Perl 5.011
803
804     'imprecision'       => 92,
805     'illegalproto'      => 94,
806
807     # Warnings Categories added in Perl 5.013
808
809     'non_unicode'       => 96,
810     'nonchar'           => 98,
811     'surrogate'         => 100,
812
813     # Warnings Categories added in Perl 5.017
814
815     'experimental'      => 102,
816     'experimental::lexical_subs'=> 104,
817     'experimental::lexical_topic'=> 106,
818     'experimental::regex_sets'=> 108,
819     'experimental::smartmatch'=> 110,
820
821     # Warnings Categories added in Perl 5.019
822
823     'experimental::autoderef'=> 112,
824     'experimental::postderef'=> 114,
825     'experimental::signatures'=> 116,
826     'syscalls'          => 118,
827
828     # Warnings Categories added in Perl 5.021
829
830     'experimental::lvalue_refs'=> 120,
831     'experimental::win32_perlio'=> 122,
832     'missing'           => 124,
833     'redundant'         => 126,
834   );
835
836 our %Bits = (
837     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..63]
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]
847     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x15\x05", # [51..58,60,61]
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]
851     'experimental::lvalue_refs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [60]
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]
856     'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [61]
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]
866     'missing'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [62]
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]
883     'redundant'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [63]
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]
901   );
902
903 our %DeadBits = (
904     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..63]
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]
914     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x2a\x0a", # [51..58,60,61]
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]
918     'experimental::lvalue_refs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [60]
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]
923     'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [61]
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]
933     'missing'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [62]
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]
950     'redundant'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [63]
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]
968   );
969
970 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
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 ;
973 $BYTES    = 16 ;
974
975 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
976
977 sub Croaker
978 {
979     require Carp; # this initializes %CarpInternal
980     local $Carp::CarpInternal{'warnings'};
981     delete $Carp::CarpInternal{'warnings'};
982     Carp::croak(@_);
983 }
984
985 sub _bits {
986     my $mask = shift ;
987     my $catmask ;
988     my $fatal = 0 ;
989     my $no_fatal = 0 ;
990
991     foreach my $word ( @_ ) {
992         if ($word eq 'FATAL') {
993             $fatal = 1;
994             $no_fatal = 0;
995         }
996         elsif ($word eq 'NONFATAL') {
997             $fatal = 0;
998             $no_fatal = 1;
999         }
1000         elsif ($catmask = $Bits{$word}) {
1001             $mask |= $catmask ;
1002             $mask |= $DeadBits{$word} if $fatal ;
1003             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
1004         }
1005         else
1006           { Croaker("Unknown warnings category '$word'")}
1007     }
1008
1009     return $mask ;
1010 }
1011
1012 sub bits
1013 {
1014     # called from B::Deparse.pm
1015     push @_, 'all' unless @_ ;
1016     return _bits(undef, @_) ;
1017 }
1018
1019 sub import
1020 {
1021     shift;
1022
1023     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
1024
1025     if (vec($mask, $Offsets{'all'}, 1)) {
1026         $mask |= $Bits{'all'} ;
1027         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1028     }
1029
1030     # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
1031     push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
1032
1033     # Empty @_ is equivalent to @_ = 'all' ;
1034     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
1035 }
1036
1037 sub unimport
1038 {
1039     shift;
1040
1041     my $catmask ;
1042     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
1043
1044     if (vec($mask, $Offsets{'all'}, 1)) {
1045         $mask |= $Bits{'all'} ;
1046         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1047     }
1048
1049     # append 'all' when implied (empty import list or after a lone "FATAL")
1050     push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
1051
1052     foreach my $word ( @_ ) {
1053         if ($word eq 'FATAL') {
1054             next;
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 ;
1064 }
1065
1066 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
1067
1068 sub MESSAGE () { 4 };
1069 sub FATAL () { 2 };
1070 sub NORMAL () { 1 };
1071
1072 sub __chk
1073 {
1074     my $category ;
1075     my $offset ;
1076     my $isobj = 0 ;
1077     my $wanted = shift;
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;
1087
1088     if (@_) {
1089         # check the category supplied.
1090         $category = shift ;
1091         if (my $type = ref $category) {
1092             Croaker("not an object")
1093                 if exists $builtin_type{$type};
1094             $category = $type;
1095             $isobj = 1 ;
1096         }
1097         $offset = $Offsets{$category};
1098         Croaker("Unknown warnings category '$category'")
1099             unless defined $offset;
1100     }
1101     else {
1102         $category = (caller(1))[0] ;
1103         $offset = $Offsets{$category};
1104         Croaker("package '$category' not registered for warnings")
1105             unless defined $offset ;
1106     }
1107
1108     my $i;
1109
1110     if ($isobj) {
1111         my $pkg;
1112         $i = 2;
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 {
1119         $i = _error_loc(); # see where Carp will allocate the error
1120     }
1121
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 ;
1127
1128     my @results;
1129     foreach my $type (FATAL, NORMAL) {
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     }
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);
1148 }
1149
1150 sub _mkMask
1151 {
1152     my ($bit) = @_;
1153     my $mask = "";
1154
1155     vec($mask, $bit, 1) = 1;
1156     return $mask;
1157 }
1158
1159 sub register_categories
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
1177 sub _error_loc {
1178     require Carp;
1179     goto &Carp::short_error_loc; # don't introduce another stack frame
1180 }
1181
1182 sub enabled
1183 {
1184     return __chk(NORMAL, @_);
1185 }
1186
1187 sub fatal_enabled
1188 {
1189     return __chk(FATAL, @_);
1190 }
1191
1192 sub warn
1193 {
1194     return __chk(FATAL | MESSAGE, @_);
1195 }
1196
1197 sub warnif
1198 {
1199     return __chk(NORMAL | FATAL | MESSAGE, @_);
1200 }
1201
1202 # These are not part of any public interface, so we can delete them to save
1203 # space.
1204 delete @warnings::{qw(NORMAL FATAL MESSAGE)};
1205
1206 1;
1207
1208 # ex: set ro: