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