feb95c971b2fcee31bad6da88c86a22db500d733
[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 && $k ne 'experimental')
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 In all the descriptions below, $category can also be a warnings category
491 and ID separated by a colon, such as "experimental:lexical_subs".  See
492 L<perllexwarn/Individual Warning IDs>.
493
494 =over 4
495
496 =item use warnings::register
497
498 Creates a new warnings category with the same name as the package where
499 the call to the pragma is used.
500
501 =item warnings::enabled()
502
503 Use the warnings category with the same name as the current package.
504
505 Return TRUE if that warnings category is enabled in the calling module.
506 Otherwise returns FALSE.
507
508 =item warnings::enabled($category)
509
510 Return TRUE if the warnings category, C<$category>, is enabled in the
511 calling module.
512 Otherwise returns FALSE.
513
514 =item warnings::enabled($object)
515
516 Use the name of the class for the object reference, C<$object>, as the
517 warnings category.
518
519 Return TRUE if that warnings category is enabled in the first scope
520 where the object is used.
521 Otherwise returns FALSE.
522
523 =item warnings::fatal_enabled()
524
525 Return TRUE if the warnings category with the same name as the current
526 package has been set to FATAL in the calling module.
527 Otherwise returns FALSE.
528
529 =item warnings::fatal_enabled($category)
530
531 Return TRUE if the warnings category C<$category> has been set to FATAL in
532 the calling module.
533 Otherwise returns FALSE.
534
535 =item warnings::fatal_enabled($object)
536
537 Use the name of the class for the object reference, C<$object>, as the
538 warnings category.
539
540 Return TRUE if that warnings category has been set to FATAL in the first
541 scope where the object is used.
542 Otherwise returns FALSE.
543
544 =item warnings::warn($message)
545
546 Print C<$message> to STDERR.
547
548 Use the warnings category with the same name as the current package.
549
550 If that warnings category has been set to "FATAL" in the calling module
551 then die. Otherwise return.
552
553 =item warnings::warn($category, $message)
554
555 Print C<$message> to STDERR.
556
557 If the warnings category, C<$category>, has been set to "FATAL" in the
558 calling module then die. Otherwise return.
559
560 =item warnings::warn($object, $message)
561
562 Print C<$message> to STDERR.
563
564 Use the name of the class for the object reference, C<$object>, as the
565 warnings category.
566
567 If that warnings category has been set to "FATAL" in the scope where C<$object>
568 is first used then die. Otherwise return.
569
570
571 =item warnings::warnif($message)
572
573 Equivalent to:
574
575     if (warnings::enabled())
576       { warnings::warn($message) }
577
578 =item warnings::warnif($category, $message)
579
580 Equivalent to:
581
582     if (warnings::enabled($category))
583       { warnings::warn($category, $message) }
584
585 =item warnings::warnif($object, $message)
586
587 Equivalent to:
588
589     if (warnings::enabled($object))
590       { warnings::warn($object, $message) }
591
592 =item warnings::register_categories(@names)
593
594 This registers warning categories for the given names and is primarily for
595 use by the warnings::register pragma, for which see L<perllexwarn>.
596
597 =back
598
599 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
600
601 =cut
602
603 KEYWORDS
604
605 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
606
607 sub Croaker
608 {
609     require Carp; # this initializes %CarpInternal
610     local $Carp::CarpInternal{'warnings'};
611     delete $Carp::CarpInternal{'warnings'};
612     Carp::croak(@_);
613 }
614
615 sub _bits {
616     my $mask = shift ;
617     my $catmask ;
618     my $fatal = 0 ;
619     my $no_fatal = 0 ;
620
621     foreach my $word ( @_ ) {
622         if ($word eq 'FATAL') {
623             $fatal = 1;
624             $no_fatal = 0;
625         }
626         elsif ($word eq 'NONFATAL') {
627             $fatal = 0;
628             $no_fatal = 1;
629         }
630         elsif ($catmask = $Bits{$word}) {
631             $mask |= $catmask ;
632             $mask |= $DeadBits{$word} if $fatal ;
633             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
634         }
635         else
636           { Croaker("Unknown warnings category '$word'")}
637     }
638
639     return $mask ;
640 }
641
642 sub bits
643 {
644     # called from B::Deparse.pm
645     push @_, 'all' unless @_ ;
646     return _bits(undef, @_) ;
647 }
648
649 sub import 
650 {
651     shift;
652
653     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
654
655     if (vec($mask, $Offsets{'all'}, 1)) {
656         $mask |= $Bits{'all'} ;
657         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
658     }
659     
660     # Empty @_ is equivalent to @_ = 'all' ;
661     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
662 }
663
664 sub unimport 
665 {
666     shift;
667
668     my $catmask ;
669     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
670
671     if (vec($mask, $Offsets{'all'}, 1)) {
672         $mask |= $Bits{'all'} ;
673         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
674     }
675
676     push @_, 'all' unless @_;
677
678     foreach my $word ( @_ ) {
679         if ($word eq 'FATAL') {
680             next; 
681         }
682         elsif ($catmask = $Bits{$word}) {
683             $mask &= ~($catmask | $DeadBits{$word} | $All);
684         }
685         else
686           { Croaker("Unknown warnings category '$word'")}
687     }
688
689     ${^WARNING_BITS} = $mask ;
690 }
691
692 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
693
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
706     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
707         my $sub = (caller 1)[3];
708         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
709         Croaker("Usage: $sub($syntax)");
710     }
711
712     my $message = pop if $has_message;
713
714     if (@_) {
715         # check the category supplied.
716         $category = shift ;
717         if (my $type = ref $category) {
718             Croaker("not an object")
719                 if exists $builtin_type{$type};
720             $category = $type;
721             $isobj = 1 ;
722         }
723         $offset = $Offsets{$category};
724         Croaker("Unknown warnings category '$category'")
725             unless defined $offset;
726     }
727     else {
728         $category = (caller(1))[0] ;
729         $offset = $Offsets{$category};
730         Croaker("package '$category' not registered for warnings")
731             unless defined $offset ;
732     }
733
734     my $i;
735
736     if ($isobj) {
737         my $pkg;
738         $i = 2;
739         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
740             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
741         }
742         $i -= 2 ;
743     }
744     else {
745         $i = _error_loc(); # see where Carp will allocate the error
746     }
747
748     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
749     # explicitly returns undef.
750     my(@callers_bitmask) = (caller($i))[9] ;
751     my $callers_bitmask =
752          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
753
754     my @results;
755     foreach my $type (FATAL, NORMAL) {
756         next unless $wanted & $type;
757
758         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
759                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
760     }
761
762     # &enabled and &fatal_enabled
763     return $results[0] unless $has_message;
764
765     # &warnif, and the category is neither enabled as warning nor as fatal
766     return if $wanted == (NORMAL | FATAL | MESSAGE)
767         && !($results[0] || $results[1]);
768
769     require Carp;
770     Carp::croak($message) if $results[0];
771     # will always get here for &warn. will only get here for &warnif if the
772     # category is enabled
773     Carp::carp($message);
774 }
775
776 sub _mkMask
777 {
778     my ($bit) = @_;
779     my $mask = "";
780
781     vec($mask, $bit, 1) = 1;
782     return $mask;
783 }
784
785 sub register_categories
786 {
787     my @names = @_;
788
789     for my $name (@names) {
790         if (! defined $Bits{$name}) {
791             $Bits{$name}     = _mkMask($LAST_BIT);
792             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
793             $Offsets{$name}  = $LAST_BIT ++;
794             foreach my $k (keys %Bits) {
795                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
796             }
797             $DeadBits{$name} = _mkMask($LAST_BIT);
798             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
799         }
800     }
801 }
802
803 sub _error_loc {
804     require Carp;
805     goto &Carp::short_error_loc; # don't introduce another stack frame
806 }
807
808 sub enabled
809 {
810     return __chk(NORMAL, @_);
811 }
812
813 sub fatal_enabled
814 {
815     return __chk(FATAL, @_);
816 }
817
818 sub warn
819 {
820     return __chk(FATAL | MESSAGE, @_);
821 }
822
823 sub warnif
824 {
825     return __chk(NORMAL | FATAL | MESSAGE, @_);
826 }
827
828 # These are not part of any public interface, so we can delete them to save
829 # space.
830 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
831
832 1;