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