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