This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Note that the warnings categories are documented
[perl5.git] / regen / warnings.pl
1 #!/usr/bin/perl
2 #
3 # Regenerate (overwriting only if changed):
4 #
5 #    lib/warnings.pm
6 #    warnings.h
7 #
8 # from information hardcoded into this script (the $tree hash), plus the
9 # template for warnings.pm in the DATA section.
10 #
11 # When changing the number of warnings, t/op/caller.t should change to
12 # correspond with the value of $BYTES in lib/warnings.pm
13 #
14 # With an argument of 'tree', just dump the contents of $tree and exits.
15 # Also accepts the standard regen_lib -q and -v args.
16 #
17 # This script is normally invoked from regen.pl.
18
19 $VERSION = '1.45';
20
21 BEGIN {
22     require './regen/regen_lib.pl';
23     push @INC, './lib';
24 }
25 use strict ;
26
27 sub DEFAULT_ON  () { 1 }
28 sub DEFAULT_OFF () { 2 }
29
30 my $tree = {
31 'all' => [ 5.008, {
32         'io'            => [ 5.008, {
33                                 'pipe'          => [ 5.008, DEFAULT_OFF],
34                                 'unopened'      => [ 5.008, DEFAULT_OFF],
35                                 'closed'        => [ 5.008, DEFAULT_OFF],
36                                 'newline'       => [ 5.008, DEFAULT_OFF],
37                                 'exec'          => [ 5.008, DEFAULT_OFF],
38                                 'layer'         => [ 5.008, DEFAULT_OFF],
39                                 'syscalls'      => [ 5.019, DEFAULT_OFF],
40                            }],
41         'syntax'        => [ 5.008, {
42                                 'ambiguous'     => [ 5.008, DEFAULT_OFF],
43                                 'semicolon'     => [ 5.008, DEFAULT_OFF],
44                                 'precedence'    => [ 5.008, DEFAULT_OFF],
45                                 'bareword'      => [ 5.008, DEFAULT_OFF],
46                                 'reserved'      => [ 5.008, DEFAULT_OFF],
47                                 'digit'         => [ 5.008, DEFAULT_OFF],
48                                 'parenthesis'   => [ 5.008, DEFAULT_OFF],
49                                 'printf'        => [ 5.008, DEFAULT_OFF],
50                                 'prototype'     => [ 5.008, DEFAULT_OFF],
51                                 'qw'            => [ 5.008, DEFAULT_OFF],
52                                 'illegalproto'  => [ 5.011, DEFAULT_OFF],
53                            }],
54         'severe'        => [ 5.008, {
55                                 'inplace'       => [ 5.008, DEFAULT_ON],
56                                 'internal'      => [ 5.008, DEFAULT_OFF],
57                                 'debugging'     => [ 5.008, DEFAULT_ON],
58                                 'malloc'        => [ 5.008, DEFAULT_ON],
59                            }],
60         'deprecated'    => [ 5.008, DEFAULT_ON],
61         'void'          => [ 5.008, DEFAULT_OFF],
62         'recursion'     => [ 5.008, DEFAULT_OFF],
63         'redefine'      => [ 5.008, DEFAULT_OFF],
64         'numeric'       => [ 5.008, DEFAULT_OFF],
65         'uninitialized' => [ 5.008, DEFAULT_OFF],
66         'once'          => [ 5.008, DEFAULT_OFF],
67         'misc'          => [ 5.008, DEFAULT_OFF],
68         'regexp'        => [ 5.008, DEFAULT_OFF],
69         'glob'          => [ 5.008, DEFAULT_ON],
70         'untie'         => [ 5.008, DEFAULT_OFF],
71         'substr'        => [ 5.008, DEFAULT_OFF],
72         'taint'         => [ 5.008, DEFAULT_OFF],
73         'signal'        => [ 5.008, DEFAULT_OFF],
74         'closure'       => [ 5.008, DEFAULT_OFF],
75         'overflow'      => [ 5.008, DEFAULT_OFF],
76         'portable'      => [ 5.008, DEFAULT_OFF],
77         'utf8'          => [ 5.008, {
78                                 'surrogate' => [ 5.013, DEFAULT_OFF],
79                                 'nonchar' => [ 5.013, DEFAULT_OFF],
80                                 'non_unicode' => [ 5.013, DEFAULT_OFF],
81                         }],
82         'exiting'       => [ 5.008, DEFAULT_OFF],
83         'pack'          => [ 5.008, DEFAULT_OFF],
84         'unpack'        => [ 5.008, DEFAULT_OFF],
85         'threads'       => [ 5.008, DEFAULT_OFF],
86         'imprecision'   => [ 5.011, DEFAULT_OFF],
87         'experimental'  => [ 5.017, {
88                                 'experimental::lexical_subs' =>
89                                     [ 5.017, DEFAULT_ON ],
90                                 'experimental::regex_sets' =>
91                                     [ 5.017, DEFAULT_ON ],
92                                 'experimental::smartmatch' =>
93                                     [ 5.017, DEFAULT_ON ],
94                                 'experimental::postderef' =>
95                                     [ 5.019, DEFAULT_ON ],
96                                 'experimental::signatures' =>
97                                     [ 5.019, DEFAULT_ON ],
98                                 'experimental::win32_perlio' =>
99                                     [ 5.021, DEFAULT_ON ],
100                                 'experimental::refaliasing' =>
101                                     [ 5.021, DEFAULT_ON ],
102                                 'experimental::re_strict' =>
103                                     [ 5.021, DEFAULT_ON ],
104                                 'experimental::const_attr' =>
105                                     [ 5.021, DEFAULT_ON ],
106                                 'experimental::bitwise' =>
107                                     [ 5.021, DEFAULT_ON ],
108                                 'experimental::declared_refs' =>
109                                     [ 5.025, DEFAULT_ON ],
110                                 'experimental::script_run' =>
111                                     [ 5.027, DEFAULT_ON ],
112                                 'experimental::alpha_assertions' =>
113                                     [ 5.027, DEFAULT_ON ],
114                                 'experimental::private_use' =>
115                                     [ 5.029, DEFAULT_ON ],
116                                 'experimental::uniprop_wildcards' =>
117                                     [ 5.029, DEFAULT_ON ],
118                                 'experimental::vlb' =>
119                                     [ 5.029, DEFAULT_ON ],
120                         }],
121
122         'missing'       => [ 5.021, DEFAULT_OFF],
123         'redundant'     => [ 5.021, DEFAULT_OFF],
124         'locale'        => [ 5.021, DEFAULT_ON],
125         'shadow'        => [ 5.027, DEFAULT_OFF],
126
127          #'default'     => [ 5.008, DEFAULT_ON ],
128 }]};
129
130 my @def ;
131 my %list ;
132 my %Value ;
133 my %ValueToName ;
134 my %NameToValue ;
135
136 my %v_list = () ;
137
138 sub valueWalk
139 {
140     my $tre = shift ;
141     my @list = () ;
142     my ($k, $v) ;
143
144     foreach $k (sort keys %$tre) {
145         $v = $tre->{$k};
146         die "duplicate key $k\n" if defined $list{$k} ;
147         die "Value associated with key '$k' is not an ARRAY reference"
148             if !ref $v || ref $v ne 'ARRAY' ;
149
150         my ($ver, $rest) = @{ $v } ;
151         push @{ $v_list{$ver} }, $k;
152
153         if (ref $rest)
154           { valueWalk ($rest) }
155
156     }
157
158 }
159
160 sub orderValues
161 {
162     my $index = 0;
163     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
164         foreach my $name (@{ $v_list{$ver} } ) {
165             $ValueToName{ $index } = [ uc $name, $ver ] ;
166             $NameToValue{ uc $name } = $index ++ ;
167         }
168     }
169
170     return $index ;
171 }
172
173 ###########################################################################
174
175 sub walk
176 {
177     my $tre = shift ;
178     my @list = () ;
179     my ($k, $v) ;
180
181     foreach $k (sort keys %$tre) {
182         $v = $tre->{$k};
183         die "duplicate key $k\n" if defined $list{$k} ;
184         die "Can't find key '$k'"
185             if ! defined $NameToValue{uc $k} ;
186         push @{ $list{$k} }, $NameToValue{uc $k} ;
187         die "Value associated with key '$k' is not an ARRAY reference"
188             if !ref $v || ref $v ne 'ARRAY' ;
189
190         my ($ver, $rest) = @{ $v } ;
191         if (ref $rest)
192           { push (@{ $list{$k} }, walk ($rest)) }
193         elsif ($rest == DEFAULT_ON)
194           { push @def, $NameToValue{uc $k} }
195
196         push @list, @{ $list{$k} } ;
197     }
198
199    return @list ;
200 }
201
202 ###########################################################################
203
204 sub mkRange
205 {
206     my @a = @_ ;
207     my @out = @a ;
208
209     for my $i (1 .. @a - 1) {
210         $out[$i] = ".."
211           if $a[$i] == $a[$i - 1] + 1
212              && ($i >= @a  - 1 || $a[$i] + 1 == $a[$i + 1] );
213     }
214     $out[-1] = $a[-1] if $out[-1] eq "..";
215
216     my $out = join(",",@out);
217
218     $out =~ s/,(\.\.,)+/../g ;
219     return $out;
220 }
221
222 ###########################################################################
223 sub warningsTree
224 {
225     my $tre = shift ;
226     my $prefix = shift ;
227     my ($k, $v) ;
228
229     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
230     my @keys = sort keys %$tre ;
231
232     my $rv = '';
233
234     while ($k = shift @keys) {
235         $v = $tre->{$k};
236         die "Value associated with key '$k' is not an ARRAY reference"
237             if !ref $v || ref $v ne 'ARRAY' ;
238
239         my $offset ;
240         if ($tre ne $tree) {
241             $rv .= $prefix . "|\n" ;
242             $rv .= $prefix . "+- $k" ;
243             $offset = ' ' x ($max + 4) ;
244         }
245         else {
246             $rv .= $prefix . "$k" ;
247             $offset = ' ' x ($max + 1) ;
248         }
249
250         my ($ver, $rest) = @{ $v } ;
251         if (ref $rest)
252         {
253             my $bar = @keys ? "|" : " ";
254             $rv .= " -" . "-" x ($max - length $k ) . "+\n" ;
255             $rv .= warningsTree ($rest, $prefix . $bar . $offset )
256         }
257         else
258           { $rv .= "\n" }
259     }
260
261     return $rv;
262 }
263
264 ###########################################################################
265
266 sub mkHexOct
267 {
268     my ($f, $max, @a) = @_ ;
269     my $mask = "\x00" x $max ;
270     my $string = "" ;
271
272     foreach (@a) {
273         vec($mask, $_, 1) = 1 ;
274     }
275
276     foreach (unpack("C*", $mask)) {
277         if ($f eq 'x') {
278             $string .= '\x' . sprintf("%2.2x", $_)
279         }
280         else {
281             $string .= '\\' . sprintf("%o", $_)
282         }
283     }
284     return $string ;
285 }
286
287 sub mkHex
288 {
289     my($max, @a) = @_;
290     return mkHexOct("x", $max, @a);
291 }
292
293 sub mkOct
294 {
295     my($max, @a) = @_;
296     return mkHexOct("o", $max, @a);
297 }
298
299 ###########################################################################
300
301 if (@ARGV && $ARGV[0] eq "tree")
302 {
303     print warningsTree($tree, "    ") ;
304     exit ;
305 }
306
307 my ($warn, $pm) = map {
308     open_new($_, '>', { by => 'regen/warnings.pl' });
309 } 'warnings.h', 'lib/warnings.pm';
310
311 my ($index, $warn_size);
312
313 {
314   # generate warnings.h
315
316   print $warn <<'EOM';
317
318 #define Off(x)                  ((x) / 8)
319 #define Bit(x)                  (1 << ((x) % 8))
320 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
321
322
323 #define G_WARN_OFF              0       /* $^W == 0 */
324 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
325 #define G_WARN_ALL_ON           2       /* -W flag */
326 #define G_WARN_ALL_OFF          4       /* -X flag */
327 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
328 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
329
330 #define pWARN_STD               NULL
331 #define pWARN_ALL               (STRLEN *) &PL_WARN_ALL    /* use warnings 'all' */
332 #define pWARN_NONE              (STRLEN *) &PL_WARN_NONE   /* no  warnings 'all' */
333
334 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
335                                  (x) == pWARN_NONE)
336
337 /* if PL_warnhook is set to this value, then warnings die */
338 #define PERL_WARNHOOK_FATAL     (&PL_sv_placeholder)
339 EOM
340
341   my $offset = 0 ;
342
343   valueWalk ($tree) ;
344   $index = orderValues();
345
346   die <<EOM if $index > 255 ;
347 Too many warnings categories -- max is 255
348     rewrite packWARN* & unpackWARN* macros
349 EOM
350
351   walk ($tree) ;
352   for (my $i = $index; $i & 3; $i++) {
353       push @{$list{all}}, $i;
354   }
355
356   $index *= 2 ;
357   $warn_size = int($index / 8) + ($index % 8 != 0) ;
358
359   my $k ;
360   my $last_ver = 0;
361   my @names;
362   foreach $k (sort { $a <=> $b } keys %ValueToName) {
363       my ($name, $version) = @{ $ValueToName{$k} };
364       print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
365           if $last_ver != $version ;
366       $name =~ y/:/_/;
367       $name = "WARN_$name";
368       print $warn tab(6, "#define $name"), " $k\n" ;
369       push @names, $name;
370       $last_ver = $version ;
371   }
372   print $warn "\n\n/*\n" ;
373
374   print $warn map { "=for apidoc Amnh||$_\n" } @names;
375   print $warn "\n=cut\n*/\n\n" ;
376
377   print $warn tab(6, '#define WARNsize'),       " $warn_size\n" ;
378   print $warn tab(6, '#define WARN_ALLstring'), ' "', ('\125' x $warn_size) , "\"\n" ;
379   print $warn tab(6, '#define WARN_NONEstring'), ' "', ('\0' x $warn_size) , "\"\n" ;
380
381   print $warn <<'EOM';
382
383 #define isLEXWARN_on \
384         cBOOL(PL_curcop && PL_curcop->cop_warnings != pWARN_STD)
385 #define isLEXWARN_off \
386         cBOOL(!PL_curcop || PL_curcop->cop_warnings == pWARN_STD)
387 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
388 #define isWARN_on(c,x)  (IsSet((U8 *)(c + 1), 2*(x)))
389 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
390
391 #define DUP_WARNINGS(p) Perl_dup_warnings(aTHX_ p)
392
393 /*
394
395 =head1 Warning and Dieing
396
397 In all these calls, the C<U32 wI<n>> parameters are warning category
398 constants.  You can see the ones currently available in
399 L<warnings/Category Hierarchy>, just capitalize all letters in the names
400 and prefix them by C<WARN_>.  So, for example, the category C<void> used in a
401 perl program becomes C<WARN_VOID> when used in XS code and passed to one of
402 the calls below.
403
404 =for apidoc Am|bool|ckWARN|U32 w
405
406 Returns a boolean as to whether or not warnings are enabled for the warning
407 category C<w>.  If the category is by default enabled even if not within the
408 scope of S<C<use warnings>>, instead use the L</ckWARN_d> macro.
409
410 =for apidoc Am|bool|ckWARN_d|U32 w
411
412 Like C<L</ckWARN>>, but for use if and only if the warning category is by
413 default enabled even if not within the scope of S<C<use warnings>>.
414
415 =for apidoc Am|bool|ckWARN2|U32 w1|U32 w2
416
417 Like C<L</ckWARN>>, but takes two warnings categories as input, and returns
418 TRUE if either is enabled.  If either category is by default enabled even if
419 not within the scope of S<C<use warnings>>, instead use the L</ckWARN2_d>
420 macro.  The categories must be completely independent, one may not be
421 subclassed from the other.
422
423 =for apidoc Am|bool|ckWARN2_d|U32 w1|U32 w2
424
425 Like C<L</ckWARN2>>, but for use if and only if either warning category is by
426 default enabled even if not within the scope of S<C<use warnings>>.
427
428 =for apidoc Am|bool|ckWARN3|U32 w1|U32 w2|U32 w3
429
430 Like C<L</ckWARN2>>, but takes three warnings categories as input, and returns
431 TRUE if any is enabled.  If any of the categories is by default enabled even
432 if not within the scope of S<C<use warnings>>, instead use the L</ckWARN3_d>
433 macro.  The categories must be completely independent, one may not be
434 subclassed from any other.
435
436 =for apidoc Am|bool|ckWARN3_d|U32 w1|U32 w2|U32 w3
437
438 Like C<L</ckWARN3>>, but for use if and only if any of the warning categories
439 is by default enabled even if not within the scope of S<C<use warnings>>.
440
441 =for apidoc Am|bool|ckWARN4|U32 w1|U32 w2|U32 w3|U32 w4
442
443 Like C<L</ckWARN3>>, but takes four warnings categories as input, and returns
444 TRUE if any is enabled.  If any of the categories is by default enabled even
445 if not within the scope of S<C<use warnings>>, instead use the L</ckWARN4_d>
446 macro.  The categories must be completely independent, one may not be
447 subclassed from any other.
448
449 =for apidoc Am|bool|ckWARN4_d|U32 w1|U32 w2|U32 w3|U32 w4
450
451 Like C<L</ckWARN4>>, but for use if and only if any of the warning categories
452 is by default enabled even if not within the scope of S<C<use warnings>>.
453
454 =cut
455
456 */
457
458 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
459
460 /* The w1, w2 ... should be independent warnings categories; one shouldn't be
461  * a subcategory of any other */
462
463 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
464 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
465 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
466
467 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
468 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
469 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
470 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
471
472 #define WARNshift               8
473
474 #define packWARN(a)             (a                                      )
475
476 /* The a, b, ... should be independent warnings categories; one shouldn't be
477  * a subcategory of any other */
478
479 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
480 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
481 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
482
483 #define unpackWARN1(x)          ((x)        & 0xFF)
484 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
485 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
486 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
487
488 #define ckDEAD(x)                                                       \
489    (PL_curcop &&                                                        \
490     !specialWARN(PL_curcop->cop_warnings) &&                            \
491     (isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||             \
492       (unpackWARN2(x) &&                                                \
493         (isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||         \
494           (unpackWARN3(x) &&                                            \
495             (isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||     \
496               (unpackWARN4(x) &&                                        \
497                 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))))))))
498
499 /* end of file warnings.h */
500 EOM
501
502   read_only_bottom_close_and_rename($warn);
503 }
504
505 while (<DATA>) {
506     last if /^VERSION$/ ;
507     print $pm $_ ;
508 }
509
510 print $pm qq(our \$VERSION = "$::VERSION";\n);
511
512 while (<DATA>) {
513     last if /^KEYWORDS$/ ;
514     print $pm $_ ;
515 }
516
517 my $last_ver = 0;
518 print $pm "our %Offsets = (" ;
519 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
520     my ($name, $version) = @{ $ValueToName{$k} };
521     $name = lc $name;
522     $k *= 2 ;
523     if ( $last_ver != $version ) {
524         print $pm "\n";
525         print $pm tab(6, "    # Warnings Categories added in Perl $version");
526         print $pm "\n";
527     }
528     print $pm tab(6, "    '$name'"), "=> $k,\n" ;
529     $last_ver = $version;
530 }
531
532 print $pm ");\n\n" ;
533
534 print $pm "our %Bits = (\n" ;
535 foreach my $k (sort keys  %list) {
536
537     my $v = $list{$k} ;
538     my @list = sort { $a <=> $b } @$v ;
539
540     print $pm tab(6, "    '$k'"), '=> "',
541                 mkHex($warn_size, map $_ * 2 , @list),
542                 '", # [', mkRange(@list), "]\n" ;
543 }
544
545 print $pm ");\n\n" ;
546
547 print $pm "our %DeadBits = (\n" ;
548 foreach my $k (sort keys  %list) {
549
550     my $v = $list{$k} ;
551     my @list = sort { $a <=> $b } @$v ;
552
553     print $pm tab(6, "    '$k'"), '=> "',
554                 mkHex($warn_size, map $_ * 2 + 1 , @list),
555                 '", # [', mkRange(@list), "]\n" ;
556 }
557
558 print $pm ");\n\n" ;
559 print $pm "# These are used by various things, including our own tests\n";
560 print $pm tab(6, 'our $NONE'), '=  "', ('\0' x $warn_size) , "\";\n" ;
561 print $pm tab(6, 'our $DEFAULT'), '=  "', mkHex($warn_size, map $_ * 2, @def),
562                            '", # [', mkRange(sort { $a <=> $b } @def), "]\n" ;
563 print $pm tab(6, 'our $LAST_BIT'), '=  ' . "$index ;\n" ;
564 print $pm tab(6, 'our $BYTES'),    '=  ' . "$warn_size ;\n" ;
565 while (<DATA>) {
566     if ($_ eq "=for warnings.pl tree-goes-here\n") {
567       print $pm warningsTree($tree, "    ");
568       next;
569     }
570     print $pm $_ ;
571 }
572
573 read_only_bottom_close_and_rename($pm);
574
575 __END__
576 package warnings;
577
578 VERSION
579
580 # Verify that we're called correctly so that warnings will work.
581 # Can't use Carp, since Carp uses us!
582 # String regexps because constant folding = smaller optree = less memory vs regexp literal
583 # see also strict.pm.
584 die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2]
585     if __FILE__ !~ ( '(?x) \b     '.__PACKAGE__.'  \.pmc? \z' )
586     && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' );
587
588 KEYWORDS
589
590 sub Croaker
591 {
592     require Carp; # this initializes %CarpInternal
593     local $Carp::CarpInternal{'warnings'};
594     delete $Carp::CarpInternal{'warnings'};
595     Carp::croak(@_);
596 }
597
598 sub _expand_bits {
599     my $bits = shift;
600     my $want_len = ($LAST_BIT + 7) >> 3;
601     my $len = length($bits);
602     if ($len != $want_len) {
603         if ($bits eq "") {
604             $bits = "\x00" x $want_len;
605         } elsif ($len > $want_len) {
606             substr $bits, $want_len, $len-$want_len, "";
607         } else {
608             my $a = vec($bits, $Offsets{all} >> 1, 2);
609             $a |= $a << 2;
610             $a |= $a << 4;
611             $bits .= chr($a) x ($want_len - $len);
612         }
613     }
614     return $bits;
615 }
616
617 sub _bits {
618     my $mask = shift ;
619     my $catmask ;
620     my $fatal = 0 ;
621     my $no_fatal = 0 ;
622
623     $mask = _expand_bits($mask);
624     foreach my $word ( @_ ) {
625         if ($word eq 'FATAL') {
626             $fatal = 1;
627             $no_fatal = 0;
628         }
629         elsif ($word eq 'NONFATAL') {
630             $fatal = 0;
631             $no_fatal = 1;
632         }
633         elsif ($catmask = $Bits{$word}) {
634             $mask |= $catmask ;
635             $mask |= $DeadBits{$word} if $fatal ;
636             $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ;
637         }
638         else
639           { Croaker("Unknown warnings category '$word'")}
640     }
641
642     return $mask ;
643 }
644
645 sub bits
646 {
647     # called from B::Deparse.pm
648     push @_, 'all' unless @_ ;
649     return _bits("", @_) ;
650 }
651
652 sub import
653 {
654     shift;
655
656     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
657
658     # append 'all' when implied (empty import list or after a lone
659     # "FATAL" or "NONFATAL")
660     push @_, 'all'
661         if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL'));
662
663     ${^WARNING_BITS} = _bits($mask, @_);
664 }
665
666 sub unimport
667 {
668     shift;
669
670     my $catmask ;
671     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
672
673     # append 'all' when implied (empty import list or after a lone "FATAL")
674     push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
675
676     $mask = _expand_bits($mask);
677     foreach my $word ( @_ ) {
678         if ($word eq 'FATAL') {
679             next;
680         }
681         elsif ($catmask = $Bits{$word}) {
682             $mask = ~(~$mask | $catmask | $DeadBits{$word});
683         }
684         else
685           { Croaker("Unknown warnings category '$word'")}
686     }
687
688     ${^WARNING_BITS} = $mask ;
689 }
690
691 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
692
693 sub LEVEL () { 8 };
694 sub MESSAGE () { 4 };
695 sub FATAL () { 2 };
696 sub NORMAL () { 1 };
697
698 sub __chk
699 {
700     my $category ;
701     my $offset ;
702     my $isobj = 0 ;
703     my $wanted = shift;
704     my $has_message = $wanted & MESSAGE;
705     my $has_level   = $wanted & LEVEL  ;
706
707     if ($has_level) {
708         if (@_ != ($has_message ? 3 : 2)) {
709             my $sub = (caller 1)[3];
710             my $syntax = $has_message
711                 ? "category, level, 'message'"
712                 : 'category, level';
713             Croaker("Usage: $sub($syntax)");
714         }
715     }
716     elsif (not @_ == 1 || @_ == ($has_message ? 2 : 0)) {
717         my $sub = (caller 1)[3];
718         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
719         Croaker("Usage: $sub($syntax)");
720     }
721
722     my $message = pop if $has_message;
723
724     if (@_) {
725         # check the category supplied.
726         $category = shift ;
727         if (my $type = ref $category) {
728             Croaker("not an object")
729                 if exists $builtin_type{$type};
730             $category = $type;
731             $isobj = 1 ;
732         }
733         $offset = $Offsets{$category};
734         Croaker("Unknown warnings category '$category'")
735             unless defined $offset;
736     }
737     else {
738         $category = (caller(1))[0] ;
739         $offset = $Offsets{$category};
740         Croaker("package '$category' not registered for warnings")
741             unless defined $offset ;
742     }
743
744     my $i;
745
746     if ($isobj) {
747         my $pkg;
748         $i = 2;
749         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
750             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
751         }
752         $i -= 2 ;
753     }
754     elsif ($has_level) {
755         $i = 2 + shift;
756     }
757     else {
758         $i = _error_loc(); # see where Carp will allocate the error
759     }
760
761     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
762     # explicitly returns undef.
763     my(@callers_bitmask) = (caller($i))[9] ;
764     my $callers_bitmask =
765          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
766     length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all};
767
768     my @results;
769     foreach my $type (FATAL, NORMAL) {
770         next unless $wanted & $type;
771
772         push @results, vec($callers_bitmask, $offset + $type - 1, 1);
773     }
774
775     # &enabled and &fatal_enabled
776     return $results[0] unless $has_message;
777
778     # &warnif, and the category is neither enabled as warning nor as fatal
779     return if ($wanted & (NORMAL | FATAL | MESSAGE))
780                       == (NORMAL | FATAL | MESSAGE)
781         && !($results[0] || $results[1]);
782
783     # If we have an explicit level, bypass Carp.
784     if ($has_level and @callers_bitmask) {
785         # logic copied from util.c:mess_sv
786         my $stuff = " at " . join " line ", (caller $i)[1,2];
787         $stuff .= sprintf ", <%s> %s %d",
788                            *${^LAST_FH}{NAME},
789                            ($/ eq "\n" ? "line" : "chunk"), $.
790             if $. && ${^LAST_FH};
791         die "$message$stuff.\n" if $results[0];
792         return warn "$message$stuff.\n";
793     }
794
795     require Carp;
796     Carp::croak($message) if $results[0];
797     # will always get here for &warn. will only get here for &warnif if the
798     # category is enabled
799     Carp::carp($message);
800 }
801
802 sub _mkMask
803 {
804     my ($bit) = @_;
805     my $mask = "";
806
807     vec($mask, $bit, 1) = 1;
808     return $mask;
809 }
810
811 sub register_categories
812 {
813     my @names = @_;
814
815     for my $name (@names) {
816         if (! defined $Bits{$name}) {
817             $Offsets{$name}  = $LAST_BIT;
818             $Bits{$name}     = _mkMask($LAST_BIT++);
819             $DeadBits{$name} = _mkMask($LAST_BIT++);
820             if (length($Bits{$name}) > length($Bits{all})) {
821                 $Bits{all} .= "\x55";
822                 $DeadBits{all} .= "\xaa";
823             }
824         }
825     }
826 }
827
828 sub _error_loc {
829     require Carp;
830     goto &Carp::short_error_loc; # don't introduce another stack frame
831 }
832
833 sub enabled
834 {
835     return __chk(NORMAL, @_);
836 }
837
838 sub fatal_enabled
839 {
840     return __chk(FATAL, @_);
841 }
842
843 sub warn
844 {
845     return __chk(FATAL | MESSAGE, @_);
846 }
847
848 sub warnif
849 {
850     return __chk(NORMAL | FATAL | MESSAGE, @_);
851 }
852
853 sub enabled_at_level
854 {
855     return __chk(NORMAL | LEVEL, @_);
856 }
857
858 sub fatal_enabled_at_level
859 {
860     return __chk(FATAL | LEVEL, @_);
861 }
862
863 sub warn_at_level
864 {
865     return __chk(FATAL | MESSAGE | LEVEL, @_);
866 }
867
868 sub warnif_at_level
869 {
870     return __chk(NORMAL | FATAL | MESSAGE | LEVEL, @_);
871 }
872
873 # These are not part of any public interface, so we can delete them to save
874 # space.
875 delete @warnings::{qw(NORMAL FATAL MESSAGE LEVEL)};
876
877 1;
878 __END__
879
880 =head1 NAME
881
882 warnings - Perl pragma to control optional warnings
883
884 =head1 SYNOPSIS
885
886     use warnings;
887     no warnings;
888
889     use warnings "all";
890     no warnings "all";
891
892     use warnings::register;
893     if (warnings::enabled()) {
894         warnings::warn("some warning");
895     }
896
897     if (warnings::enabled("void")) {
898         warnings::warn("void", "some warning");
899     }
900
901     if (warnings::enabled($object)) {
902         warnings::warn($object, "some warning");
903     }
904
905     warnings::warnif("some warning");
906     warnings::warnif("void", "some warning");
907     warnings::warnif($object, "some warning");
908
909 =head1 DESCRIPTION
910
911 The C<warnings> pragma gives control over which warnings are enabled in
912 which parts of a Perl program.  It's a more flexible alternative for
913 both the command line flag B<-w> and the equivalent Perl variable,
914 C<$^W>.
915
916 This pragma works just like the C<strict> pragma.
917 This means that the scope of the warning pragma is limited to the
918 enclosing block.  It also means that the pragma setting will not
919 leak across files (via C<use>, C<require> or C<do>).  This allows
920 authors to independently define the degree of warning checks that will
921 be applied to their module.
922
923 By default, optional warnings are disabled, so any legacy code that
924 doesn't attempt to control the warnings will work unchanged.
925
926 All warnings are enabled in a block by either of these:
927
928     use warnings;
929     use warnings 'all';
930
931 Similarly all warnings are disabled in a block by either of these:
932
933     no warnings;
934     no warnings 'all';
935
936 For example, consider the code below:
937
938     use warnings;
939     my @a;
940     {
941         no warnings;
942         my $b = @a[0];
943     }
944     my $c = @a[0];
945
946 The code in the enclosing block has warnings enabled, but the inner
947 block has them disabled.  In this case that means the assignment to the
948 scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]">
949 warning, but the assignment to the scalar C<$b> will not.
950
951 =head2 Default Warnings and Optional Warnings
952
953 Before the introduction of lexical warnings, Perl had two classes of
954 warnings: mandatory and optional.
955
956 As its name suggests, if your code tripped a mandatory warning, you
957 would get a warning whether you wanted it or not.
958 For example, the code below would always produce an C<"isn't numeric">
959 warning about the "2:".
960
961     my $a = "2:" + 3;
962
963 With the introduction of lexical warnings, mandatory warnings now become
964 I<default> warnings.  The difference is that although the previously
965 mandatory warnings are still enabled by default, they can then be
966 subsequently enabled or disabled with the lexical warning pragma.  For
967 example, in the code below, an C<"isn't numeric"> warning will only
968 be reported for the C<$a> variable.
969
970     my $a = "2:" + 3;
971     no warnings;
972     my $b = "2:" + 3;
973
974 Note that neither the B<-w> flag or the C<$^W> can be used to
975 disable/enable default warnings.  They are still mandatory in this case.
976
977 =head2 What's wrong with B<-w> and C<$^W>
978
979 Although very useful, the big problem with using B<-w> on the command
980 line to enable warnings is that it is all or nothing.  Take the typical
981 scenario when you are writing a Perl program.  Parts of the code you
982 will write yourself, but it's very likely that you will make use of
983 pre-written Perl modules.  If you use the B<-w> flag in this case, you
984 end up enabling warnings in pieces of code that you haven't written.
985
986 Similarly, using C<$^W> to either disable or enable blocks of code is
987 fundamentally flawed.  For a start, say you want to disable warnings in
988 a block of code.  You might expect this to be enough to do the trick:
989
990      {
991          local ($^W) = 0;
992          my $a =+ 2;
993          my $b; chop $b;
994      }
995
996 When this code is run with the B<-w> flag, a warning will be produced
997 for the C<$a> line:  C<"Reversed += operator">.
998
999 The problem is that Perl has both compile-time and run-time warnings.  To
1000 disable compile-time warnings you need to rewrite the code like this:
1001
1002      {
1003          BEGIN { $^W = 0 }
1004          my $a =+ 2;
1005          my $b; chop $b;
1006      }
1007
1008 The other big problem with C<$^W> is the way you can inadvertently
1009 change the warning setting in unexpected places in your code.  For example,
1010 when the code below is run (without the B<-w> flag), the second call
1011 to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
1012 the first will not.
1013
1014     sub doit
1015     {
1016         my $b; chop $b;
1017     }
1018
1019     doit();
1020
1021     {
1022         local ($^W) = 1;
1023         doit()
1024     }
1025
1026 This is a side-effect of C<$^W> being dynamically scoped.
1027
1028 Lexical warnings get around these limitations by allowing finer control
1029 over where warnings can or can't be tripped.
1030
1031 =head2 Controlling Warnings from the Command Line
1032
1033 There are three Command Line flags that can be used to control when
1034 warnings are (or aren't) produced:
1035
1036 =over 5
1037
1038 =item B<-w>
1039 X<-w>
1040
1041 This is  the existing flag.  If the lexical warnings pragma is B<not>
1042 used in any of you code, or any of the modules that you use, this flag
1043 will enable warnings everywhere.  See L</Backward Compatibility> for
1044 details of how this flag interacts with lexical warnings.
1045
1046 =item B<-W>
1047 X<-W>
1048
1049 If the B<-W> flag is used on the command line, it will enable all warnings
1050 throughout the program regardless of whether warnings were disabled
1051 locally using C<no warnings> or C<$^W =0>.
1052 This includes all files that get
1053 included via C<use>, C<require> or C<do>.
1054 Think of it as the Perl equivalent of the "lint" command.
1055
1056 =item B<-X>
1057 X<-X>
1058
1059 Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
1060
1061 =back
1062
1063 =head2 Backward Compatibility
1064
1065 If you are used to working with a version of Perl prior to the
1066 introduction of lexically scoped warnings, or have code that uses both
1067 lexical warnings and C<$^W>, this section will describe how they interact.
1068
1069 How Lexical Warnings interact with B<-w>/C<$^W>:
1070
1071 =over 5
1072
1073 =item 1.
1074
1075 If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
1076 control warnings is used and neither C<$^W> nor the C<warnings> pragma
1077 are used, then default warnings will be enabled and optional warnings
1078 disabled.
1079 This means that legacy code that doesn't attempt to control the warnings
1080 will work unchanged.
1081
1082 =item 2.
1083
1084 The B<-w> flag just sets the global C<$^W> variable as in 5.005.  This
1085 means that any legacy code that currently relies on manipulating C<$^W>
1086 to control warning behavior will still work as is.
1087
1088 =item 3.
1089
1090 Apart from now being a boolean, the C<$^W> variable operates in exactly
1091 the same horrible uncontrolled global way, except that it cannot
1092 disable/enable default warnings.
1093
1094 =item 4.
1095
1096 If a piece of code is under the control of the C<warnings> pragma,
1097 both the C<$^W> variable and the B<-w> flag will be ignored for the
1098 scope of the lexical warning.
1099
1100 =item 5.
1101
1102 The only way to override a lexical warnings setting is with the B<-W>
1103 or B<-X> command line flags.
1104
1105 =back
1106
1107 The combined effect of 3 & 4 is that it will allow code which uses
1108 the C<warnings> pragma to control the warning behavior of $^W-type
1109 code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
1110
1111 =head2 Category Hierarchy
1112 X<warning, categories>
1113
1114 A hierarchy of "categories" have been defined to allow groups of warnings
1115 to be enabled/disabled in isolation.
1116
1117 The current hierarchy is:
1118
1119 =for warnings.pl tree-goes-here
1120
1121 Just like the "strict" pragma any of these categories can be combined
1122
1123     use warnings qw(void redefine);
1124     no warnings qw(io syntax untie);
1125
1126 Also like the "strict" pragma, if there is more than one instance of the
1127 C<warnings> pragma in a given scope the cumulative effect is additive.
1128
1129     use warnings qw(void); # only "void" warnings enabled
1130     ...
1131     use warnings qw(io);   # only "void" & "io" warnings enabled
1132     ...
1133     no warnings qw(void);  # only "io" warnings enabled
1134
1135 To determine which category a specific warning has been assigned to see
1136 L<perldiag>.
1137
1138 Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
1139 sub-category of the "syntax" category.  It is now a top-level category
1140 in its own right.
1141
1142 Note: Before 5.21.0, the "missing" lexical warnings category was
1143 internally defined to be the same as the "uninitialized" category. It
1144 is now a top-level category in its own right.
1145
1146 =head2 Fatal Warnings
1147 X<warning, fatal>
1148
1149 The presence of the word "FATAL" in the category list will escalate
1150 warnings in those categories into fatal errors in that lexical scope.
1151
1152 B<NOTE:> FATAL warnings should be used with care, particularly
1153 C<< FATAL => 'all' >>.
1154
1155 Libraries using L<warnings::warn|/FUNCTIONS> for custom warning categories
1156 generally don't expect L<warnings::warn|/FUNCTIONS> to be fatal and can wind up
1157 in an unexpected state as a result.  For XS modules issuing categorized
1158 warnings, such unanticipated exceptions could also expose memory leak bugs.
1159
1160 Moreover, the Perl interpreter itself has had serious bugs involving
1161 fatalized warnings.  For a summary of resolved and unresolved problems as
1162 of January 2015, please see
1163 L<this perl5-porters post|http://www.nntp.perl.org/group/perl.perl5.porters/2015/01/msg225235.html>.
1164
1165 While some developers find fatalizing some warnings to be a useful
1166 defensive programming technique, using C<< FATAL => 'all' >> to fatalize
1167 all possible warning categories -- including custom ones -- is particularly
1168 risky.  Therefore, the use of C<< FATAL => 'all' >> is
1169 L<discouraged|perlpolicy/discouraged>.
1170
1171 The L<strictures|strictures/VERSION-2> module on CPAN offers one example of
1172 a warnings subset that the module's authors believe is relatively safe to
1173 fatalize.
1174
1175 B<NOTE:> users of FATAL warnings, especially those using
1176 C<< FATAL => 'all' >>, should be fully aware that they are risking future
1177 portability of their programs by doing so.  Perl makes absolutely no
1178 commitments to not introduce new warnings or warnings categories in the
1179 future; indeed, we explicitly reserve the right to do so.  Code that may
1180 not warn now may warn in a future release of Perl if the Perl5 development
1181 team deems it in the best interests of the community to do so.  Should code
1182 using FATAL warnings break due to the introduction of a new warning we will
1183 NOT consider it an incompatible change.  Users of FATAL warnings should
1184 take special caution during upgrades to check to see if their code triggers
1185 any new warnings and should pay particular attention to the fine print of
1186 the documentation of the features they use to ensure they do not exploit
1187 features that are documented as risky, deprecated, or unspecified, or where
1188 the documentation says "so don't do that", or anything with the same sense
1189 and spirit.  Use of such features in combination with FATAL warnings is
1190 ENTIRELY AT THE USER'S RISK.
1191
1192 The following documentation describes how to use FATAL warnings but the
1193 perl5 porters strongly recommend that you understand the risks before doing
1194 so, especially for library code intended for use by others, as there is no
1195 way for downstream users to change the choice of fatal categories.
1196
1197 In the code below, the use of C<time>, C<length>
1198 and C<join> can all produce a C<"Useless use of xxx in void context">
1199 warning.
1200
1201     use warnings;
1202
1203     time;
1204
1205     {
1206         use warnings FATAL => qw(void);
1207         length "abc";
1208     }
1209
1210     join "", 1,2,3;
1211
1212     print "done\n";
1213
1214 When run it produces this output
1215
1216     Useless use of time in void context at fatal line 3.
1217     Useless use of length in void context at fatal line 7.
1218
1219 The scope where C<length> is used has escalated the C<void> warnings
1220 category into a fatal error, so the program terminates immediately when it
1221 encounters the warning.
1222
1223 To explicitly turn off a "FATAL" warning you just disable the warning
1224 it is associated with.  So, for example, to disable the "void" warning
1225 in the example above, either of these will do the trick:
1226
1227     no warnings qw(void);
1228     no warnings FATAL => qw(void);
1229
1230 If you want to downgrade a warning that has been escalated into a fatal
1231 error back to a normal warning, you can use the "NONFATAL" keyword.  For
1232 example, the code below will promote all warnings into fatal errors,
1233 except for those in the "syntax" category.
1234
1235     use warnings FATAL => 'all', NONFATAL => 'syntax';
1236
1237 As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
1238 use:
1239
1240    use v5.20;       # Perl 5.20 or greater is required for the following
1241    use warnings 'FATAL';  # short form of "use warnings FATAL => 'all';"
1242
1243 If you want your program to be compatible with versions of Perl before
1244 5.20, you must use C<< use warnings FATAL => 'all'; >> instead.  (In
1245 previous versions of Perl, the behavior of the statements
1246 C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
1247 C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
1248 they included the C<< => 'all' >> portion.  As of 5.20, they do.)
1249
1250 =head2 Reporting Warnings from a Module
1251 X<warning, reporting> X<warning, registering>
1252
1253 The C<warnings> pragma provides a number of functions that are useful for
1254 module authors.  These are used when you want to report a module-specific
1255 warning to a calling module has enabled warnings via the C<warnings>
1256 pragma.
1257
1258 Consider the module C<MyMod::Abc> below.
1259
1260     package MyMod::Abc;
1261
1262     use warnings::register;
1263
1264     sub open {
1265         my $path = shift;
1266         if ($path !~ m#^/#) {
1267             warnings::warn("changing relative path to /var/abc")
1268                 if warnings::enabled();
1269             $path = "/var/abc/$path";
1270         }
1271     }
1272
1273     1;
1274
1275 The call to C<warnings::register> will create a new warnings category
1276 called "MyMod::Abc", i.e. the new category name matches the current
1277 package name.  The C<open> function in the module will display a warning
1278 message if it gets given a relative path as a parameter.  This warnings
1279 will only be displayed if the code that uses C<MyMod::Abc> has actually
1280 enabled them with the C<warnings> pragma like below.
1281
1282     use MyMod::Abc;
1283     use warnings 'MyMod::Abc';
1284     ...
1285     abc::open("../fred.txt");
1286
1287 It is also possible to test whether the pre-defined warnings categories are
1288 set in the calling module with the C<warnings::enabled> function.  Consider
1289 this snippet of code:
1290
1291     package MyMod::Abc;
1292
1293     sub open {
1294         if (warnings::enabled("deprecated")) {
1295             warnings::warn("deprecated",
1296                            "open is deprecated, use new instead");
1297         }
1298         new(@_);
1299     }
1300
1301     sub new
1302     ...
1303     1;
1304
1305 The function C<open> has been deprecated, so code has been included to
1306 display a warning message whenever the calling module has (at least) the
1307 "deprecated" warnings category enabled.  Something like this, say.
1308
1309     use warnings 'deprecated';
1310     use MyMod::Abc;
1311     ...
1312     MyMod::Abc::open($filename);
1313
1314 Either the C<warnings::warn> or C<warnings::warnif> function should be
1315 used to actually display the warnings message.  This is because they can
1316 make use of the feature that allows warnings to be escalated into fatal
1317 errors.  So in this case
1318
1319     use MyMod::Abc;
1320     use warnings FATAL => 'MyMod::Abc';
1321     ...
1322     MyMod::Abc::open('../fred.txt');
1323
1324 the C<warnings::warnif> function will detect this and die after
1325 displaying the warning message.
1326
1327 The three warnings functions, C<warnings::warn>, C<warnings::warnif>
1328 and C<warnings::enabled> can optionally take an object reference in place
1329 of a category name.  In this case the functions will use the class name
1330 of the object as the warnings category.
1331
1332 Consider this example:
1333
1334     package Original;
1335
1336     no warnings;
1337     use warnings::register;
1338
1339     sub new
1340     {
1341         my $class = shift;
1342         bless [], $class;
1343     }
1344
1345     sub check
1346     {
1347         my $self = shift;
1348         my $value = shift;
1349
1350         if ($value % 2 && warnings::enabled($self))
1351           { warnings::warn($self, "Odd numbers are unsafe") }
1352     }
1353
1354     sub doit
1355     {
1356         my $self = shift;
1357         my $value = shift;
1358         $self->check($value);
1359         # ...
1360     }
1361
1362     1;
1363
1364     package Derived;
1365
1366     use warnings::register;
1367     use Original;
1368     our @ISA = qw( Original );
1369     sub new
1370     {
1371         my $class = shift;
1372         bless [], $class;
1373     }
1374
1375
1376     1;
1377
1378 The code below makes use of both modules, but it only enables warnings from
1379 C<Derived>.
1380
1381     use Original;
1382     use Derived;
1383     use warnings 'Derived';
1384     my $a = Original->new();
1385     $a->doit(1);
1386     my $b = Derived->new();
1387     $a->doit(1);
1388
1389 When this code is run only the C<Derived> object, C<$b>, will generate
1390 a warning.
1391
1392     Odd numbers are unsafe at main.pl line 7
1393
1394 Notice also that the warning is reported at the line where the object is first
1395 used.
1396
1397 When registering new categories of warning, you can supply more names to
1398 warnings::register like this:
1399
1400     package MyModule;
1401     use warnings::register qw(format precision);
1402
1403     ...
1404
1405     warnings::warnif('MyModule::format', '...');
1406
1407 =head1 FUNCTIONS
1408
1409 Note: The functions with names ending in C<_at_level> were added in Perl
1410 5.28.
1411
1412 =over 4
1413
1414 =item use warnings::register
1415
1416 Creates a new warnings category with the same name as the package where
1417 the call to the pragma is used.
1418
1419 =item warnings::enabled()
1420
1421 Use the warnings category with the same name as the current package.
1422
1423 Return TRUE if that warnings category is enabled in the calling module.
1424 Otherwise returns FALSE.
1425
1426 =item warnings::enabled($category)
1427
1428 Return TRUE if the warnings category, C<$category>, is enabled in the
1429 calling module.
1430 Otherwise returns FALSE.
1431
1432 =item warnings::enabled($object)
1433
1434 Use the name of the class for the object reference, C<$object>, as the
1435 warnings category.
1436
1437 Return TRUE if that warnings category is enabled in the first scope
1438 where the object is used.
1439 Otherwise returns FALSE.
1440
1441 =item warnings::enabled_at_level($category, $level)
1442
1443 Like C<warnings::enabled>, but $level specifies the exact call frame, 0
1444 being the immediate caller.
1445
1446 =item warnings::fatal_enabled()
1447
1448 Return TRUE if the warnings category with the same name as the current
1449 package has been set to FATAL in the calling module.
1450 Otherwise returns FALSE.
1451
1452 =item warnings::fatal_enabled($category)
1453
1454 Return TRUE if the warnings category C<$category> has been set to FATAL in
1455 the calling module.
1456 Otherwise returns FALSE.
1457
1458 =item warnings::fatal_enabled($object)
1459
1460 Use the name of the class for the object reference, C<$object>, as the
1461 warnings category.
1462
1463 Return TRUE if that warnings category has been set to FATAL in the first
1464 scope where the object is used.
1465 Otherwise returns FALSE.
1466
1467 =item warnings::fatal_enabled_at_level($category, $level)
1468
1469 Like C<warnings::fatal_enabled>, but $level specifies the exact call frame,
1470 0 being the immediate caller.
1471
1472 =item warnings::warn($message)
1473
1474 Print C<$message> to STDERR.
1475
1476 Use the warnings category with the same name as the current package.
1477
1478 If that warnings category has been set to "FATAL" in the calling module
1479 then die. Otherwise return.
1480
1481 =item warnings::warn($category, $message)
1482
1483 Print C<$message> to STDERR.
1484
1485 If the warnings category, C<$category>, has been set to "FATAL" in the
1486 calling module then die. Otherwise return.
1487
1488 =item warnings::warn($object, $message)
1489
1490 Print C<$message> to STDERR.
1491
1492 Use the name of the class for the object reference, C<$object>, as the
1493 warnings category.
1494
1495 If that warnings category has been set to "FATAL" in the scope where C<$object>
1496 is first used then die. Otherwise return.
1497
1498 =item warnings::warn_at_level($category, $level, $message)
1499
1500 Like C<warnings::warn>, but $level specifies the exact call frame,
1501 0 being the immediate caller.
1502
1503 =item warnings::warnif($message)
1504
1505 Equivalent to:
1506
1507     if (warnings::enabled())
1508       { warnings::warn($message) }
1509
1510 =item warnings::warnif($category, $message)
1511
1512 Equivalent to:
1513
1514     if (warnings::enabled($category))
1515       { warnings::warn($category, $message) }
1516
1517 =item warnings::warnif($object, $message)
1518
1519 Equivalent to:
1520
1521     if (warnings::enabled($object))
1522       { warnings::warn($object, $message) }
1523
1524 =item warnings::warnif_at_level($category, $level, $message)
1525
1526 Like C<warnings::warnif>, but $level specifies the exact call frame,
1527 0 being the immediate caller.
1528
1529 =item warnings::register_categories(@names)
1530
1531 This registers warning categories for the given names and is primarily for
1532 use by the warnings::register pragma.
1533
1534 =back
1535
1536 See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.
1537
1538 =cut