utf8.c: Use slightly more efficient macro
[perl.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::postderef
273          |                 |
274          |                 +- experimental::regex_sets
275          |                 |
276          |                 +- experimental::signatures
277          |                 |
278          |                 +- experimental::smartmatch
279          |                 |
280          |                 +- experimental::win32_perlio
281          |
282          +- glob
283          |
284          +- imprecision
285          |
286          +- io ------------+
287          |                 |
288          |                 +- closed
289          |                 |
290          |                 +- exec
291          |                 |
292          |                 +- layer
293          |                 |
294          |                 +- newline
295          |                 |
296          |                 +- pipe
297          |                 |
298          |                 +- syscalls
299          |                 |
300          |                 +- unopened
301          |
302          +- misc
303          |
304          +- missing
305          |
306          +- numeric
307          |
308          +- once
309          |
310          +- overflow
311          |
312          +- pack
313          |
314          +- portable
315          |
316          +- recursion
317          |
318          +- redefine
319          |
320          +- redundant
321          |
322          +- regexp
323          |
324          +- severe --------+
325          |                 |
326          |                 +- debugging
327          |                 |
328          |                 +- inplace
329          |                 |
330          |                 +- internal
331          |                 |
332          |                 +- malloc
333          |
334          +- signal
335          |
336          +- substr
337          |
338          +- syntax --------+
339          |                 |
340          |                 +- ambiguous
341          |                 |
342          |                 +- bareword
343          |                 |
344          |                 +- digit
345          |                 |
346          |                 +- illegalproto
347          |                 |
348          |                 +- parenthesis
349          |                 |
350          |                 +- precedence
351          |                 |
352          |                 +- printf
353          |                 |
354          |                 +- prototype
355          |                 |
356          |                 +- qw
357          |                 |
358          |                 +- reserved
359          |                 |
360          |                 +- semicolon
361          |
362          +- taint
363          |
364          +- threads
365          |
366          +- uninitialized
367          |
368          +- unpack
369          |
370          +- untie
371          |
372          +- utf8 ----------+
373          |                 |
374          |                 +- non_unicode
375          |                 |
376          |                 +- nonchar
377          |                 |
378          |                 +- surrogate
379          |
380          +- void
381
382 Just like the "strict" pragma any of these categories can be combined
383
384     use warnings qw(void redefine);
385     no warnings qw(io syntax untie);
386
387 Also like the "strict" pragma, if there is more than one instance of the
388 C<warnings> pragma in a given scope the cumulative effect is additive. 
389
390     use warnings qw(void); # only "void" warnings enabled
391     ...
392     use warnings qw(io);   # only "void" & "io" warnings enabled
393     ...
394     no warnings qw(void);  # only "io" warnings enabled
395
396 To determine which category a specific warning has been assigned to see
397 L<perldiag>.
398
399 Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
400 sub-category of the "syntax" category.  It is now a top-level category
401 in its own right.
402
403 Note: Before 5.21.0, the "missing" lexical warnings category was
404 internally defined to be the same as the "uninitialized" category. It
405 is now a top-level category in its own right.
406
407 =head2 Fatal Warnings
408 X<warning, fatal>
409
410 The presence of the word "FATAL" in the category list will escalate any
411 warnings detected from the categories specified in the lexical scope
412 into fatal errors.  In the code below, the use of C<time>, C<length>
413 and C<join> can all produce a C<"Useless use of xxx in void context">
414 warning.
415
416     use warnings;
417
418     time;
419
420     {
421         use warnings FATAL => qw(void);
422         length "abc";
423     }
424
425     join "", 1,2,3;
426
427     print "done\n";
428
429 When run it produces this output
430
431     Useless use of time in void context at fatal line 3.
432     Useless use of length in void context at fatal line 7.  
433
434 The scope where C<length> is used has escalated the C<void> warnings
435 category into a fatal error, so the program terminates immediately when it
436 encounters the warning.
437
438 To explicitly turn off a "FATAL" warning you just disable the warning
439 it is associated with.  So, for example, to disable the "void" warning
440 in the example above, either of these will do the trick:
441
442     no warnings qw(void);
443     no warnings FATAL => qw(void);
444
445 If you want to downgrade a warning that has been escalated into a fatal
446 error back to a normal warning, you can use the "NONFATAL" keyword.  For
447 example, the code below will promote all warnings into fatal errors,
448 except for those in the "syntax" category.
449
450     use warnings FATAL => 'all', NONFATAL => 'syntax';
451
452 As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
453 use:
454
455    use v5.20;       # Perl 5.20 or greater is required for the following
456    use warnings 'FATAL';  # short form of "use warnings FATAL => 'all';"
457
458 If you want your program to be compatible with versions of Perl before
459 5.20, you must use C<< use warnings FATAL => 'all'; >> instead.  (In
460 previous versions of Perl, the behavior of the statements
461 C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
462 C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
463 they included the C<< => 'all' >> portion.  As of 5.20, they do.)
464
465 B<NOTE:> Users of FATAL warnings, especially
466 those using C<< FATAL => 'all' >>
467 should be fully aware that they are risking future portability of their
468 programs by doing so.  Perl makes absolutely no commitments to not
469 introduce new warnings, or warnings categories in the future, and indeed
470 we explicitly reserve the right to do so.  Code that may not warn now may
471 warn in a future release of Perl if the Perl5 development team deems it
472 in the best interests of the community to do so.  Should code using FATAL
473 warnings break due to the introduction of a new warning we will NOT
474 consider it an incompatible change.  Users of FATAL warnings should take
475 special caution during upgrades to check to see if their code triggers
476 any new warnings and should pay particular attention to the fine print of
477 the documentation of the features they use to ensure they do not exploit
478 features that are documented as risky, deprecated, or unspecified, or where
479 the documentation says "so don't do that", or anything with the same sense
480 and spirit.  Use of such features in combination with FATAL warnings is
481 ENTIRELY AT THE USER'S RISK.
482
483 =head2 Reporting Warnings from a Module
484 X<warning, reporting> X<warning, registering>
485
486 The C<warnings> pragma provides a number of functions that are useful for
487 module authors.  These are used when you want to report a module-specific
488 warning to a calling module has enabled warnings via the C<warnings>
489 pragma.
490
491 Consider the module C<MyMod::Abc> below.
492
493     package MyMod::Abc;
494
495     use warnings::register;
496
497     sub open {
498         my $path = shift;
499         if ($path !~ m#^/#) {
500             warnings::warn("changing relative path to /var/abc")
501                 if warnings::enabled();
502             $path = "/var/abc/$path";
503         }
504     }
505
506     1;
507
508 The call to C<warnings::register> will create a new warnings category
509 called "MyMod::Abc", i.e. the new category name matches the current
510 package name.  The C<open> function in the module will display a warning
511 message if it gets given a relative path as a parameter.  This warnings
512 will only be displayed if the code that uses C<MyMod::Abc> has actually
513 enabled them with the C<warnings> pragma like below.
514
515     use MyMod::Abc;
516     use warnings 'MyMod::Abc';
517     ...
518     abc::open("../fred.txt");
519
520 It is also possible to test whether the pre-defined warnings categories are
521 set in the calling module with the C<warnings::enabled> function.  Consider
522 this snippet of code:
523
524     package MyMod::Abc;
525
526     sub open {
527         warnings::warnif("deprecated", 
528                          "open is deprecated, use new instead");
529         new(@_);
530     }
531
532     sub new
533     ...
534     1;
535
536 The function C<open> has been deprecated, so code has been included to
537 display a warning message whenever the calling module has (at least) the
538 "deprecated" warnings category enabled.  Something like this, say.
539
540     use warnings 'deprecated';
541     use MyMod::Abc;
542     ...
543     MyMod::Abc::open($filename);
544
545 Either the C<warnings::warn> or C<warnings::warnif> function should be
546 used to actually display the warnings message.  This is because they can
547 make use of the feature that allows warnings to be escalated into fatal
548 errors.  So in this case
549
550     use MyMod::Abc;
551     use warnings FATAL => 'MyMod::Abc';
552     ...
553     MyMod::Abc::open('../fred.txt');
554
555 the C<warnings::warnif> function will detect this and die after
556 displaying the warning message.
557
558 The three warnings functions, C<warnings::warn>, C<warnings::warnif>
559 and C<warnings::enabled> can optionally take an object reference in place
560 of a category name.  In this case the functions will use the class name
561 of the object as the warnings category.
562
563 Consider this example:
564
565     package Original;
566
567     no warnings;
568     use warnings::register;
569
570     sub new
571     {
572         my $class = shift;
573         bless [], $class;
574     }
575
576     sub check
577     {
578         my $self = shift;
579         my $value = shift;
580
581         if ($value % 2 && warnings::enabled($self))
582           { warnings::warn($self, "Odd numbers are unsafe") }
583     }
584
585     sub doit
586     {
587         my $self = shift;
588         my $value = shift;
589         $self->check($value);
590         # ...
591     }
592
593     1;
594
595     package Derived;
596
597     use warnings::register;
598     use Original;
599     our @ISA = qw( Original );
600     sub new
601     {
602         my $class = shift;
603         bless [], $class;
604     }
605
606
607     1;
608
609 The code below makes use of both modules, but it only enables warnings from 
610 C<Derived>.
611
612     use Original;
613     use Derived;
614     use warnings 'Derived';
615     my $a = Original->new();
616     $a->doit(1);
617     my $b = Derived->new();
618     $a->doit(1);
619
620 When this code is run only the C<Derived> object, C<$b>, will generate
621 a warning. 
622
623     Odd numbers are unsafe at main.pl line 7
624
625 Notice also that the warning is reported at the line where the object is first
626 used.
627
628 When registering new categories of warning, you can supply more names to
629 warnings::register like this:
630
631     package MyModule;
632     use warnings::register qw(format precision);
633
634     ...
635
636     warnings::warnif('MyModule::format', '...');
637
638 =head1 FUNCTIONS
639
640 =over 4
641
642 =item use warnings::register
643
644 Creates a new warnings category with the same name as the package where
645 the call to the pragma is used.
646
647 =item warnings::enabled()
648
649 Use the warnings category with the same name as the current package.
650
651 Return TRUE if that warnings category is enabled in the calling module.
652 Otherwise returns FALSE.
653
654 =item warnings::enabled($category)
655
656 Return TRUE if the warnings category, C<$category>, is enabled in the
657 calling module.
658 Otherwise returns FALSE.
659
660 =item warnings::enabled($object)
661
662 Use the name of the class for the object reference, C<$object>, as the
663 warnings category.
664
665 Return TRUE if that warnings category is enabled in the first scope
666 where the object is used.
667 Otherwise returns FALSE.
668
669 =item warnings::fatal_enabled()
670
671 Return TRUE if the warnings category with the same name as the current
672 package has been set to FATAL in the calling module.
673 Otherwise returns FALSE.
674
675 =item warnings::fatal_enabled($category)
676
677 Return TRUE if the warnings category C<$category> has been set to FATAL in
678 the calling module.
679 Otherwise returns FALSE.
680
681 =item warnings::fatal_enabled($object)
682
683 Use the name of the class for the object reference, C<$object>, as the
684 warnings category.
685
686 Return TRUE if that warnings category has been set to FATAL in the first
687 scope where the object is used.
688 Otherwise returns FALSE.
689
690 =item warnings::warn($message)
691
692 Print C<$message> to STDERR.
693
694 Use the warnings category with the same name as the current package.
695
696 If that warnings category has been set to "FATAL" in the calling module
697 then die. Otherwise return.
698
699 =item warnings::warn($category, $message)
700
701 Print C<$message> to STDERR.
702
703 If the warnings category, C<$category>, has been set to "FATAL" in the
704 calling module then die. Otherwise return.
705
706 =item warnings::warn($object, $message)
707
708 Print C<$message> to STDERR.
709
710 Use the name of the class for the object reference, C<$object>, as the
711 warnings category.
712
713 If that warnings category has been set to "FATAL" in the scope where C<$object>
714 is first used then die. Otherwise return.
715
716
717 =item warnings::warnif($message)
718
719 Equivalent to:
720
721     if (warnings::enabled())
722       { warnings::warn($message) }
723
724 =item warnings::warnif($category, $message)
725
726 Equivalent to:
727
728     if (warnings::enabled($category))
729       { warnings::warn($category, $message) }
730
731 =item warnings::warnif($object, $message)
732
733 Equivalent to:
734
735     if (warnings::enabled($object))
736       { warnings::warn($object, $message) }
737
738 =item warnings::register_categories(@names)
739
740 This registers warning categories for the given names and is primarily for
741 use by the warnings::register pragma.
742
743 =back
744
745 See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.
746
747 =cut
748
749 our %Offsets = (
750
751     # Warnings Categories added in Perl 5.008
752
753     'all'               => 0,
754     'closure'           => 2,
755     'deprecated'        => 4,
756     'exiting'           => 6,
757     'glob'              => 8,
758     'io'                => 10,
759     'closed'            => 12,
760     'exec'              => 14,
761     'layer'             => 16,
762     'newline'           => 18,
763     'pipe'              => 20,
764     'unopened'          => 22,
765     'misc'              => 24,
766     'numeric'           => 26,
767     'once'              => 28,
768     'overflow'          => 30,
769     'pack'              => 32,
770     'portable'          => 34,
771     'recursion'         => 36,
772     'redefine'          => 38,
773     'regexp'            => 40,
774     'severe'            => 42,
775     'debugging'         => 44,
776     'inplace'           => 46,
777     'internal'          => 48,
778     'malloc'            => 50,
779     'signal'            => 52,
780     'substr'            => 54,
781     'syntax'            => 56,
782     'ambiguous'         => 58,
783     'bareword'          => 60,
784     'digit'             => 62,
785     'parenthesis'       => 64,
786     'precedence'        => 66,
787     'printf'            => 68,
788     'prototype'         => 70,
789     'qw'                => 72,
790     'reserved'          => 74,
791     'semicolon'         => 76,
792     'taint'             => 78,
793     'threads'           => 80,
794     'uninitialized'     => 82,
795     'unpack'            => 84,
796     'untie'             => 86,
797     'utf8'              => 88,
798     'void'              => 90,
799
800     # Warnings Categories added in Perl 5.011
801
802     'imprecision'       => 92,
803     'illegalproto'      => 94,
804
805     # Warnings Categories added in Perl 5.013
806
807     'non_unicode'       => 96,
808     'nonchar'           => 98,
809     'surrogate'         => 100,
810
811     # Warnings Categories added in Perl 5.017
812
813     'experimental'      => 102,
814     'experimental::lexical_subs'=> 104,
815     'experimental::lexical_topic'=> 106,
816     'experimental::regex_sets'=> 108,
817     'experimental::smartmatch'=> 110,
818
819     # Warnings Categories added in Perl 5.019
820
821     'experimental::autoderef'=> 112,
822     'experimental::postderef'=> 114,
823     'experimental::signatures'=> 116,
824     'syscalls'          => 118,
825
826     # Warnings Categories added in Perl 5.021
827
828     'experimental::win32_perlio'=> 120,
829     'missing'           => 122,
830     'redundant'         => 124,
831   );
832
833 our %Bits = (
834     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..62]
835     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
836     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
837     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
838     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
839     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
840     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
841     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
842     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
843     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
844     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x15\x01", # [51..58,60]
845     'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [56]
846     'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [52]
847     'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [53]
848     'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [57]
849     'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [54]
850     'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [58]
851     'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [55]
852     'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [60]
853     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
854     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [47]
855     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [46]
856     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
857     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
858     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [5..11,59]
859     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
860     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
861     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
862     'missing'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [61]
863     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
864     'non_unicode'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [48]
865     'nonchar'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [49]
866     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
867     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
868     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
869     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
870     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [32]
871     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
872     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
873     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [33]
874     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [34]
875     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [35]
876     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [36]
877     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
878     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
879     'redundant'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [62]
880     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
881     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [37]
882     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [38]
883     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
884     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
885     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
886     'surrogate'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [50]
887     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00\x00", # [28..38,47]
888     'syscalls'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [59]
889     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [39]
890     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [40]
891     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [41]
892     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
893     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [42]
894     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [43]
895     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00\x00", # [44,48..50]
896     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [45]
897   );
898
899 our %DeadBits = (
900     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..62]
901     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
902     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
903     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
904     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
905     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
906     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
907     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
908     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
909     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
910     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x2a\x02", # [51..58,60]
911     'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [56]
912     'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [52]
913     'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [53]
914     'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [57]
915     'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [54]
916     'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [58]
917     'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [55]
918     'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [60]
919     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
920     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [47]
921     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [46]
922     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
923     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
924     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [5..11,59]
925     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
926     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
927     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
928     'missing'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [61]
929     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
930     'non_unicode'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [48]
931     'nonchar'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [49]
932     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
933     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
934     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
935     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
936     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [32]
937     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
938     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
939     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [33]
940     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [34]
941     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [35]
942     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [36]
943     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
944     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
945     'redundant'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [62]
946     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
947     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [37]
948     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [38]
949     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
950     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
951     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
952     'surrogate'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [50]
953     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00\x00", # [28..38,47]
954     'syscalls'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [59]
955     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [39]
956     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [40]
957     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [41]
958     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
959     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [42]
960     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [43]
961     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00\x00", # [44,48..50]
962     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [45]
963   );
964
965 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
966 $DEFAULT  = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x01", # [2,56,52,53,57,54,58,55,60,4,22,23,25]
967 $LAST_BIT = 126 ;
968 $BYTES    = 16 ;
969
970 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
971
972 sub Croaker
973 {
974     require Carp; # this initializes %CarpInternal
975     local $Carp::CarpInternal{'warnings'};
976     delete $Carp::CarpInternal{'warnings'};
977     Carp::croak(@_);
978 }
979
980 sub _bits {
981     my $mask = shift ;
982     my $catmask ;
983     my $fatal = 0 ;
984     my $no_fatal = 0 ;
985
986     foreach my $word ( @_ ) {
987         if ($word eq 'FATAL') {
988             $fatal = 1;
989             $no_fatal = 0;
990         }
991         elsif ($word eq 'NONFATAL') {
992             $fatal = 0;
993             $no_fatal = 1;
994         }
995         elsif ($catmask = $Bits{$word}) {
996             $mask |= $catmask ;
997             $mask |= $DeadBits{$word} if $fatal ;
998             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
999         }
1000         else
1001           { Croaker("Unknown warnings category '$word'")}
1002     }
1003
1004     return $mask ;
1005 }
1006
1007 sub bits
1008 {
1009     # called from B::Deparse.pm
1010     push @_, 'all' unless @_ ;
1011     return _bits(undef, @_) ;
1012 }
1013
1014 sub import
1015 {
1016     shift;
1017
1018     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
1019
1020     if (vec($mask, $Offsets{'all'}, 1)) {
1021         $mask |= $Bits{'all'} ;
1022         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1023     }
1024
1025     # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
1026     push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
1027
1028     # Empty @_ is equivalent to @_ = 'all' ;
1029     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
1030 }
1031
1032 sub unimport
1033 {
1034     shift;
1035
1036     my $catmask ;
1037     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
1038
1039     if (vec($mask, $Offsets{'all'}, 1)) {
1040         $mask |= $Bits{'all'} ;
1041         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1042     }
1043
1044     # append 'all' when implied (empty import list or after a lone "FATAL")
1045     push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
1046
1047     foreach my $word ( @_ ) {
1048         if ($word eq 'FATAL') {
1049             next;
1050         }
1051         elsif ($catmask = $Bits{$word}) {
1052             $mask &= ~($catmask | $DeadBits{$word} | $All);
1053         }
1054         else
1055           { Croaker("Unknown warnings category '$word'")}
1056     }
1057
1058     ${^WARNING_BITS} = $mask ;
1059 }
1060
1061 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
1062
1063 sub MESSAGE () { 4 };
1064 sub FATAL () { 2 };
1065 sub NORMAL () { 1 };
1066
1067 sub __chk
1068 {
1069     my $category ;
1070     my $offset ;
1071     my $isobj = 0 ;
1072     my $wanted = shift;
1073     my $has_message = $wanted & MESSAGE;
1074
1075     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
1076         my $sub = (caller 1)[3];
1077         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
1078         Croaker("Usage: $sub($syntax)");
1079     }
1080
1081     my $message = pop if $has_message;
1082
1083     if (@_) {
1084         # check the category supplied.
1085         $category = shift ;
1086         if (my $type = ref $category) {
1087             Croaker("not an object")
1088                 if exists $builtin_type{$type};
1089             $category = $type;
1090             $isobj = 1 ;
1091         }
1092         $offset = $Offsets{$category};
1093         Croaker("Unknown warnings category '$category'")
1094             unless defined $offset;
1095     }
1096     else {
1097         $category = (caller(1))[0] ;
1098         $offset = $Offsets{$category};
1099         Croaker("package '$category' not registered for warnings")
1100             unless defined $offset ;
1101     }
1102
1103     my $i;
1104
1105     if ($isobj) {
1106         my $pkg;
1107         $i = 2;
1108         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
1109             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
1110         }
1111         $i -= 2 ;
1112     }
1113     else {
1114         $i = _error_loc(); # see where Carp will allocate the error
1115     }
1116
1117     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
1118     # explicitly returns undef.
1119     my(@callers_bitmask) = (caller($i))[9] ;
1120     my $callers_bitmask =
1121          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
1122
1123     my @results;
1124     foreach my $type (FATAL, NORMAL) {
1125         next unless $wanted & $type;
1126
1127         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
1128                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
1129     }
1130
1131     # &enabled and &fatal_enabled
1132     return $results[0] unless $has_message;
1133
1134     # &warnif, and the category is neither enabled as warning nor as fatal
1135     return if $wanted == (NORMAL | FATAL | MESSAGE)
1136         && !($results[0] || $results[1]);
1137
1138     require Carp;
1139     Carp::croak($message) if $results[0];
1140     # will always get here for &warn. will only get here for &warnif if the
1141     # category is enabled
1142     Carp::carp($message);
1143 }
1144
1145 sub _mkMask
1146 {
1147     my ($bit) = @_;
1148     my $mask = "";
1149
1150     vec($mask, $bit, 1) = 1;
1151     return $mask;
1152 }
1153
1154 sub register_categories
1155 {
1156     my @names = @_;
1157
1158     for my $name (@names) {
1159         if (! defined $Bits{$name}) {
1160             $Bits{$name}     = _mkMask($LAST_BIT);
1161             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
1162             $Offsets{$name}  = $LAST_BIT ++;
1163             foreach my $k (keys %Bits) {
1164                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
1165             }
1166             $DeadBits{$name} = _mkMask($LAST_BIT);
1167             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
1168         }
1169     }
1170 }
1171
1172 sub _error_loc {
1173     require Carp;
1174     goto &Carp::short_error_loc; # don't introduce another stack frame
1175 }
1176
1177 sub enabled
1178 {
1179     return __chk(NORMAL, @_);
1180 }
1181
1182 sub fatal_enabled
1183 {
1184     return __chk(FATAL, @_);
1185 }
1186
1187 sub warn
1188 {
1189     return __chk(FATAL | MESSAGE, @_);
1190 }
1191
1192 sub warnif
1193 {
1194     return __chk(NORMAL | FATAL | MESSAGE, @_);
1195 }
1196
1197 # These are not part of any public interface, so we can delete them to save
1198 # space.
1199 delete @warnings::{qw(NORMAL FATAL MESSAGE)};
1200
1201 1;
1202
1203 # ex: set ro: