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