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