Use two colons for lexsub warning
[perl.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.02_03';
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
32 'all' => [ 5.008, {
33         'io'            => [ 5.008, {   
34                                 'pipe'          => [ 5.008, DEFAULT_OFF],
35                                 'unopened'      => [ 5.008, DEFAULT_OFF],
36                                 'closed'        => [ 5.008, DEFAULT_OFF],
37                                 'newline'       => [ 5.008, DEFAULT_OFF],
38                                 'exec'          => [ 5.008, DEFAULT_OFF],
39                                 'layer'         => [ 5.008, 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                         }],
91
92          #'default'     => [ 5.008, DEFAULT_ON ],
93         }],
94 } ;
95
96 my @def ;
97 my %list ;
98 my %Value ;
99 my %ValueToName ;
100 my %NameToValue ;
101
102 my %v_list = () ;
103
104 sub valueWalk
105 {
106     my $tre = shift ;
107     my @list = () ;
108     my ($k, $v) ;
109
110     foreach $k (sort keys %$tre) {
111         $v = $tre->{$k};
112         die "duplicate key $k\n" if defined $list{$k} ;
113         die "Value associated with key '$k' is not an ARRAY reference"
114             if !ref $v || ref $v ne 'ARRAY' ;
115
116         my ($ver, $rest) = @{ $v } ;
117         push @{ $v_list{$ver} }, $k;
118         
119         if (ref $rest)
120           { valueWalk ($rest) }
121
122     }
123
124 }
125
126 sub orderValues
127 {
128     my $index = 0;
129     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
130         foreach my $name (@{ $v_list{$ver} } ) {
131             $ValueToName{ $index } = [ uc $name, $ver ] ;
132             $NameToValue{ uc $name } = $index ++ ;
133         }
134     }
135
136     return $index ;
137 }
138
139 ###########################################################################
140
141 sub walk
142 {
143     my $tre = shift ;
144     my @list = () ;
145     my ($k, $v) ;
146
147     foreach $k (sort keys %$tre) {
148         $v = $tre->{$k};
149         die "duplicate key $k\n" if defined $list{$k} ;
150         die "Can't find key '$k'"
151             if ! defined $NameToValue{uc $k} ;
152         push @{ $list{$k} }, $NameToValue{uc $k} ;
153         die "Value associated with key '$k' is not an ARRAY reference"
154             if !ref $v || ref $v ne 'ARRAY' ;
155         
156         my ($ver, $rest) = @{ $v } ;
157         if (ref $rest)
158           { push (@{ $list{$k} }, walk ($rest)) }
159         elsif ($rest == DEFAULT_ON)
160           { push @def, $NameToValue{uc $k} }
161
162         push @list, @{ $list{$k} } ;
163     }
164
165    return @list ;
166 }
167
168 ###########################################################################
169
170 sub mkRange
171 {
172     my @a = @_ ;
173     my @out = @a ;
174
175     for my $i (1 .. @a - 1) {
176         $out[$i] = ".."
177           if $a[$i] == $a[$i - 1] + 1
178              && ($i >= @a  - 1 || $a[$i] + 1 == $a[$i + 1] );
179     }
180     $out[-1] = $a[-1] if $out[-1] eq "..";
181
182     my $out = join(",",@out);
183
184     $out =~ s/,(\.\.,)+/../g ;
185     return $out;
186 }
187
188 ###########################################################################
189 sub printTree
190 {
191     my $tre = shift ;
192     my $prefix = shift ;
193     my ($k, $v) ;
194
195     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
196     my @keys = sort keys %$tre ;
197
198     while ($k = shift @keys) {
199         $v = $tre->{$k};
200         die "Value associated with key '$k' is not an ARRAY reference"
201             if !ref $v || ref $v ne 'ARRAY' ;
202         
203         my $offset ;
204         if ($tre ne $tree) {
205             print $prefix . "|\n" ;
206             print $prefix . "+- $k" ;
207             $offset = ' ' x ($max + 4) ;
208         }
209         else {
210             print $prefix . "$k" ;
211             $offset = ' ' x ($max + 1) ;
212         }
213
214         my ($ver, $rest) = @{ $v } ;
215         if (ref $rest)
216         {
217             my $bar = @keys ? "|" : " ";
218             print " -" . "-" x ($max - length $k ) . "+\n" ;
219             printTree ($rest, $prefix . $bar . $offset )
220         }
221         else
222           { print "\n" }
223     }
224
225 }
226
227 ###########################################################################
228
229 sub mkHexOct
230 {
231     my ($f, $max, @a) = @_ ;
232     my $mask = "\x00" x $max ;
233     my $string = "" ;
234
235     foreach (@a) {
236         vec($mask, $_, 1) = 1 ;
237     }
238
239     foreach (unpack("C*", $mask)) {
240         if ($f eq 'x') {
241             $string .= '\x' . sprintf("%2.2x", $_)
242         }
243         else {
244             $string .= '\\' . sprintf("%o", $_)
245         }
246     }
247     return $string ;
248 }
249
250 sub mkHex
251 {
252     my($max, @a) = @_;
253     return mkHexOct("x", $max, @a);
254 }
255
256 sub mkOct
257 {
258     my($max, @a) = @_;
259     return mkHexOct("o", $max, @a);
260 }
261
262 ###########################################################################
263
264 if (@ARGV && $ARGV[0] eq "tree")
265 {
266     printTree($tree, "    ") ;
267     exit ;
268 }
269
270 my ($warn, $pm) = map {
271     open_new($_, '>', { by => 'regen/warnings.pl' });
272 } 'warnings.h', 'lib/warnings.pm';
273
274 print $warn <<'EOM';
275
276 #define Off(x)                  ((x) / 8)
277 #define Bit(x)                  (1 << ((x) % 8))
278 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
279
280
281 #define G_WARN_OFF              0       /* $^W == 0 */
282 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
283 #define G_WARN_ALL_ON           2       /* -W flag */
284 #define G_WARN_ALL_OFF          4       /* -X flag */
285 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
286 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
287
288 #define pWARN_STD               NULL
289 #define pWARN_ALL               (((STRLEN*)0)+1)    /* use warnings 'all' */
290 #define pWARN_NONE              (((STRLEN*)0)+2)    /* no  warnings 'all' */
291
292 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
293                                  (x) == pWARN_NONE)
294
295 /* if PL_warnhook is set to this value, then warnings die */
296 #define PERL_WARNHOOK_FATAL     (&PL_sv_placeholder)
297 EOM
298
299 my $offset = 0 ;
300
301 valueWalk ($tree) ;
302 my $index = orderValues();
303
304 die <<EOM if $index > 255 ;
305 Too many warnings categories -- max is 255
306     rewrite packWARN* & unpackWARN* macros 
307 EOM
308
309 walk ($tree) ;
310
311 $index *= 2 ;
312 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
313
314 my $k ;
315 my $last_ver = 0;
316 foreach $k (sort { $a <=> $b } keys %ValueToName) {
317     my ($name, $version) = @{ $ValueToName{$k} };
318     print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
319         if $last_ver != $version ;
320     $name =~ y/:/_/;
321     print $warn tab(5, "#define WARN_$name"), " $k\n" ;
322     $last_ver = $version ;
323 }
324 print $warn "\n" ;
325
326 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
327 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
328 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
329 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
330
331 print $warn <<'EOM';
332
333 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
334 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
335 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
336 #define isWARN_on(c,x)  (IsSet((U8 *)(c + 1), 2*(x)))
337 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
338
339 #define DUP_WARNINGS(p)         \
340     (specialWARN(p) ? (STRLEN*)(p)      \
341     : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
342                                              char))
343
344 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
345 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
346 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
347 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
348
349 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
350 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
351 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
352 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
353
354 #define WARNshift               8
355
356 #define packWARN(a)             (a                                      )
357 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
358 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
359 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
360
361 #define unpackWARN1(x)          ((x)        & 0xFF)
362 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
363 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
364 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
365
366 #define ckDEAD(x)                                                       \
367            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
368             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
369               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
370               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
371               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
372               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
373
374 /* end of file warnings.h */
375 EOM
376
377 read_only_bottom_close_and_rename($warn);
378
379 while (<DATA>) {
380     last if /^KEYWORDS$/ ;
381     print $pm $_ ;
382 }
383
384 $last_ver = 0;
385 print $pm "our %Offsets = (\n" ;
386 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
387     my ($name, $version) = @{ $ValueToName{$k} };
388     $name = lc $name;
389     $k *= 2 ;
390     if ( $last_ver != $version ) {
391         print $pm "\n";
392         print $pm tab(4, "    # Warnings Categories added in Perl $version");
393         print $pm "\n\n";
394     }
395     print $pm tab(4, "    '$name'"), "=> $k,\n" ;
396     $last_ver = $version;
397 }
398
399 print $pm "  );\n\n" ;
400
401 print $pm "our %Bits = (\n" ;
402 foreach $k (sort keys  %list) {
403
404     my $v = $list{$k} ;
405     my @list = sort { $a <=> $b } @$v ;
406
407     print $pm tab(4, "    '$k'"), '=> "',
408                 mkHex($warn_size, map $_ * 2 , @list),
409                 '", # [', mkRange(@list), "]\n" ;
410 }
411
412 print $pm "  );\n\n" ;
413
414 print $pm "our %DeadBits = (\n" ;
415 foreach $k (sort keys  %list) {
416
417     my $v = $list{$k} ;
418     my @list = sort { $a <=> $b } @$v ;
419
420     print $pm tab(4, "    '$k'"), '=> "',
421                 mkHex($warn_size, map $_ * 2 + 1 , @list),
422                 '", # [', mkRange(@list), "]\n" ;
423 }
424
425 print $pm "  );\n\n" ;
426 print $pm '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
427 print $pm '$DEFAULT  = "', mkHex($warn_size, map $_ * 2, @def),
428                            '", # [', mkRange(@def), "]\n" ;
429 print $pm '$LAST_BIT = ' . "$index ;\n" ;
430 print $pm '$BYTES    = ' . "$warn_size ;\n" ;
431 while (<DATA>) {
432     print $pm $_ ;
433 }
434
435 read_only_bottom_close_and_rename($pm);
436
437 __END__
438 package warnings;
439
440 our $VERSION = '1.14';
441
442 # Verify that we're called correctly so that warnings will work.
443 # see also strict.pm.
444 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
445     my (undef, $f, $l) = caller;
446     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
447 }
448
449 =head1 NAME
450
451 warnings - Perl pragma to control optional warnings
452
453 =head1 SYNOPSIS
454
455     use warnings;
456     no warnings;
457
458     use warnings "all";
459     no warnings "all";
460
461     use warnings::register;
462     if (warnings::enabled()) {
463         warnings::warn("some warning");
464     }
465
466     if (warnings::enabled("void")) {
467         warnings::warn("void", "some warning");
468     }
469
470     if (warnings::enabled($object)) {
471         warnings::warn($object, "some warning");
472     }
473
474     warnings::warnif("some warning");
475     warnings::warnif("void", "some warning");
476     warnings::warnif($object, "some warning");
477
478 =head1 DESCRIPTION
479
480 The C<warnings> pragma is a replacement for the command line flag C<-w>,
481 but the pragma is limited to the enclosing block, while the flag is global.
482 See L<perllexwarn> for more information and the list of built-in warning
483 categories.
484
485 If no import list is supplied, all possible warnings are either enabled
486 or disabled.
487
488 A number of functions are provided to assist module authors.
489
490 =over 4
491
492 =item use warnings::register
493
494 Creates a new warnings category with the same name as the package where
495 the call to the pragma is used.
496
497 =item warnings::enabled()
498
499 Use the warnings category with the same name as the current package.
500
501 Return TRUE if that warnings category is enabled in the calling module.
502 Otherwise returns FALSE.
503
504 =item warnings::enabled($category)
505
506 Return TRUE if the warnings category, C<$category>, is enabled in the
507 calling module.
508 Otherwise returns FALSE.
509
510 =item warnings::enabled($object)
511
512 Use the name of the class for the object reference, C<$object>, as the
513 warnings category.
514
515 Return TRUE if that warnings category is enabled in the first scope
516 where the object is used.
517 Otherwise returns FALSE.
518
519 =item warnings::fatal_enabled()
520
521 Return TRUE if the warnings category with the same name as the current
522 package has been set to FATAL in the calling module.
523 Otherwise returns FALSE.
524
525 =item warnings::fatal_enabled($category)
526
527 Return TRUE if the warnings category C<$category> has been set to FATAL in
528 the calling module.
529 Otherwise returns FALSE.
530
531 =item warnings::fatal_enabled($object)
532
533 Use the name of the class for the object reference, C<$object>, as the
534 warnings category.
535
536 Return TRUE if that warnings category has been set to FATAL in the first
537 scope where the object is used.
538 Otherwise returns FALSE.
539
540 =item warnings::warn($message)
541
542 Print C<$message> to STDERR.
543
544 Use the warnings category with the same name as the current package.
545
546 If that warnings category has been set to "FATAL" in the calling module
547 then die. Otherwise return.
548
549 =item warnings::warn($category, $message)
550
551 Print C<$message> to STDERR.
552
553 If the warnings category, C<$category>, has been set to "FATAL" in the
554 calling module then die. Otherwise return.
555
556 =item warnings::warn($object, $message)
557
558 Print C<$message> to STDERR.
559
560 Use the name of the class for the object reference, C<$object>, as the
561 warnings category.
562
563 If that warnings category has been set to "FATAL" in the scope where C<$object>
564 is first used then die. Otherwise return.
565
566
567 =item warnings::warnif($message)
568
569 Equivalent to:
570
571     if (warnings::enabled())
572       { warnings::warn($message) }
573
574 =item warnings::warnif($category, $message)
575
576 Equivalent to:
577
578     if (warnings::enabled($category))
579       { warnings::warn($category, $message) }
580
581 =item warnings::warnif($object, $message)
582
583 Equivalent to:
584
585     if (warnings::enabled($object))
586       { warnings::warn($object, $message) }
587
588 =item warnings::register_categories(@names)
589
590 This registers warning categories for the given names and is primarily for
591 use by the warnings::register pragma, for which see L<perllexwarn>.
592
593 =back
594
595 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
596
597 =cut
598
599 KEYWORDS
600
601 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
602
603 sub Croaker
604 {
605     require Carp; # this initializes %CarpInternal
606     local $Carp::CarpInternal{'warnings'};
607     delete $Carp::CarpInternal{'warnings'};
608     Carp::croak(@_);
609 }
610
611 sub _bits {
612     my $mask = shift ;
613     my $catmask ;
614     my $fatal = 0 ;
615     my $no_fatal = 0 ;
616
617     foreach my $word ( @_ ) {
618         if ($word eq 'FATAL') {
619             $fatal = 1;
620             $no_fatal = 0;
621         }
622         elsif ($word eq 'NONFATAL') {
623             $fatal = 0;
624             $no_fatal = 1;
625         }
626         elsif ($catmask = $Bits{$word}) {
627             $mask |= $catmask ;
628             $mask |= $DeadBits{$word} if $fatal ;
629             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
630         }
631         else
632           { Croaker("Unknown warnings category '$word'")}
633     }
634
635     return $mask ;
636 }
637
638 sub bits
639 {
640     # called from B::Deparse.pm
641     push @_, 'all' unless @_ ;
642     return _bits(undef, @_) ;
643 }
644
645 sub import 
646 {
647     shift;
648
649     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
650
651     if (vec($mask, $Offsets{'all'}, 1)) {
652         $mask |= $Bits{'all'} ;
653         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
654     }
655     
656     # Empty @_ is equivalent to @_ = 'all' ;
657     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
658 }
659
660 sub unimport 
661 {
662     shift;
663
664     my $catmask ;
665     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
666
667     if (vec($mask, $Offsets{'all'}, 1)) {
668         $mask |= $Bits{'all'} ;
669         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
670     }
671
672     push @_, 'all' unless @_;
673
674     foreach my $word ( @_ ) {
675         if ($word eq 'FATAL') {
676             next; 
677         }
678         elsif ($catmask = $Bits{$word}) {
679             $mask &= ~($catmask | $DeadBits{$word} | $All);
680         }
681         else
682           { Croaker("Unknown warnings category '$word'")}
683     }
684
685     ${^WARNING_BITS} = $mask ;
686 }
687
688 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
689
690 sub MESSAGE () { 4 };
691 sub FATAL () { 2 };
692 sub NORMAL () { 1 };
693
694 sub __chk
695 {
696     my $category ;
697     my $offset ;
698     my $isobj = 0 ;
699     my $wanted = shift;
700     my $has_message = $wanted & MESSAGE;
701
702     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
703         my $sub = (caller 1)[3];
704         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
705         Croaker("Usage: $sub($syntax)");
706     }
707
708     my $message = pop if $has_message;
709
710     if (@_) {
711         # check the category supplied.
712         $category = shift ;
713         if (my $type = ref $category) {
714             Croaker("not an object")
715                 if exists $builtin_type{$type};
716             $category = $type;
717             $isobj = 1 ;
718         }
719         $offset = $Offsets{$category};
720         Croaker("Unknown warnings category '$category'")
721             unless defined $offset;
722     }
723     else {
724         $category = (caller(1))[0] ;
725         $offset = $Offsets{$category};
726         Croaker("package '$category' not registered for warnings")
727             unless defined $offset ;
728     }
729
730     my $i;
731
732     if ($isobj) {
733         my $pkg;
734         $i = 2;
735         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
736             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
737         }
738         $i -= 2 ;
739     }
740     else {
741         $i = _error_loc(); # see where Carp will allocate the error
742     }
743
744     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
745     # explicitly returns undef.
746     my(@callers_bitmask) = (caller($i))[9] ;
747     my $callers_bitmask =
748          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
749
750     my @results;
751     foreach my $type (FATAL, NORMAL) {
752         next unless $wanted & $type;
753
754         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
755                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
756     }
757
758     # &enabled and &fatal_enabled
759     return $results[0] unless $has_message;
760
761     # &warnif, and the category is neither enabled as warning nor as fatal
762     return if $wanted == (NORMAL | FATAL | MESSAGE)
763         && !($results[0] || $results[1]);
764
765     require Carp;
766     Carp::croak($message) if $results[0];
767     # will always get here for &warn. will only get here for &warnif if the
768     # category is enabled
769     Carp::carp($message);
770 }
771
772 sub _mkMask
773 {
774     my ($bit) = @_;
775     my $mask = "";
776
777     vec($mask, $bit, 1) = 1;
778     return $mask;
779 }
780
781 sub register_categories
782 {
783     my @names = @_;
784
785     for my $name (@names) {
786         if (! defined $Bits{$name}) {
787             $Bits{$name}     = _mkMask($LAST_BIT);
788             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
789             $Offsets{$name}  = $LAST_BIT ++;
790             foreach my $k (keys %Bits) {
791                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
792             }
793             $DeadBits{$name} = _mkMask($LAST_BIT);
794             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
795         }
796     }
797 }
798
799 sub _error_loc {
800     require Carp;
801     goto &Carp::short_error_loc; # don't introduce another stack frame
802 }
803
804 sub enabled
805 {
806     return __chk(NORMAL, @_);
807 }
808
809 sub fatal_enabled
810 {
811     return __chk(FATAL, @_);
812 }
813
814 sub warn
815 {
816     return __chk(FATAL | MESSAGE, @_);
817 }
818
819 sub warnif
820 {
821     return __chk(NORMAL | FATAL | MESSAGE, @_);
822 }
823
824 # These are not part of any public interface, so we can delete them to save
825 # space.
826 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
827
828 1;