6eee635fc405dc1f170fb75a5dfacb38cd207bcb
[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 /* ex: set ro: */
370 EOM
371
372 close_and_rename($warn);
373
374 while (<DATA>) {
375     last if /^KEYWORDS$/ ;
376     print $pm $_ ;
377 }
378
379 $last_ver = 0;
380 print $pm "our %Offsets = (\n" ;
381 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
382     my ($name, $version) = @{ $ValueToName{$k} };
383     $name = lc $name;
384     $k *= 2 ;
385     if ( $last_ver != $version ) {
386         print $pm "\n";
387         print $pm tab(4, "    # Warnings Categories added in Perl $version");
388         print $pm "\n\n";
389     }
390     print $pm tab(4, "    '$name'"), "=> $k,\n" ;
391     $last_ver = $version;
392 }
393
394 print $pm "  );\n\n" ;
395
396 print $pm "our %Bits = (\n" ;
397 foreach $k (sort keys  %list) {
398
399     my $v = $list{$k} ;
400     my @list = sort { $a <=> $b } @$v ;
401
402     print $pm tab(4, "    '$k'"), '=> "',
403                 mkHex($warn_size, map $_ * 2 , @list),
404                 '", # [', mkRange(@list), "]\n" ;
405 }
406
407 print $pm "  );\n\n" ;
408
409 print $pm "our %DeadBits = (\n" ;
410 foreach $k (sort keys  %list) {
411
412     my $v = $list{$k} ;
413     my @list = sort { $a <=> $b } @$v ;
414
415     print $pm tab(4, "    '$k'"), '=> "',
416                 mkHex($warn_size, map $_ * 2 + 1 , @list),
417                 '", # [', mkRange(@list), "]\n" ;
418 }
419
420 print $pm "  );\n\n" ;
421 print $pm '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
422 print $pm '$LAST_BIT = ' . "$index ;\n" ;
423 print $pm '$BYTES    = ' . "$warn_size ;\n" ;
424 while (<DATA>) {
425     print $pm $_ ;
426 }
427
428 print $pm "# ex: set ro:\n";
429 close_and_rename($pm);
430
431 __END__
432 package warnings;
433
434 our $VERSION = '1.12';
435
436 # Verify that we're called correctly so that warnings will work.
437 # see also strict.pm.
438 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
439     my (undef, $f, $l) = caller;
440     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
441 }
442
443 =head1 NAME
444
445 warnings - Perl pragma to control optional warnings
446
447 =head1 SYNOPSIS
448
449     use warnings;
450     no warnings;
451
452     use warnings "all";
453     no warnings "all";
454
455     use warnings::register;
456     if (warnings::enabled()) {
457         warnings::warn("some warning");
458     }
459
460     if (warnings::enabled("void")) {
461         warnings::warn("void", "some warning");
462     }
463
464     if (warnings::enabled($object)) {
465         warnings::warn($object, "some warning");
466     }
467
468     warnings::warnif("some warning");
469     warnings::warnif("void", "some warning");
470     warnings::warnif($object, "some warning");
471
472 =head1 DESCRIPTION
473
474 The C<warnings> pragma is a replacement for the command line flag C<-w>,
475 but the pragma is limited to the enclosing block, while the flag is global.
476 See L<perllexwarn> for more information.
477
478 If no import list is supplied, all possible warnings are either enabled
479 or disabled.
480
481 A number of functions are provided to assist module authors.
482
483 =over 4
484
485 =item use warnings::register
486
487 Creates a new warnings category with the same name as the package where
488 the call to the pragma is used.
489
490 =item warnings::enabled()
491
492 Use the warnings category with the same name as the current package.
493
494 Return TRUE if that warnings category is enabled in the calling module.
495 Otherwise returns FALSE.
496
497 =item warnings::enabled($category)
498
499 Return TRUE if the warnings category, C<$category>, is enabled in the
500 calling module.
501 Otherwise returns FALSE.
502
503 =item warnings::enabled($object)
504
505 Use the name of the class for the object reference, C<$object>, as the
506 warnings category.
507
508 Return TRUE if that warnings category is enabled in the first scope
509 where the object is used.
510 Otherwise returns FALSE.
511
512 =item warnings::fatal_enabled()
513
514 Return TRUE if the warnings category with the same name as the current
515 package has been set to FATAL in the calling module.
516 Otherwise returns FALSE.
517
518 =item warnings::fatal_enabled($category)
519
520 Return TRUE if the warnings category C<$category> has been set to FATAL in
521 the calling module.
522 Otherwise returns FALSE.
523
524 =item warnings::fatal_enabled($object)
525
526 Use the name of the class for the object reference, C<$object>, as the
527 warnings category.
528
529 Return TRUE if that warnings category has been set to FATAL in the first
530 scope where the object is used.
531 Otherwise returns FALSE.
532
533 =item warnings::warn($message)
534
535 Print C<$message> to STDERR.
536
537 Use the warnings category with the same name as the current package.
538
539 If that warnings category has been set to "FATAL" in the calling module
540 then die. Otherwise return.
541
542 =item warnings::warn($category, $message)
543
544 Print C<$message> to STDERR.
545
546 If the warnings category, C<$category>, has been set to "FATAL" in the
547 calling module then die. Otherwise return.
548
549 =item warnings::warn($object, $message)
550
551 Print C<$message> to STDERR.
552
553 Use the name of the class for the object reference, C<$object>, as the
554 warnings category.
555
556 If that warnings category has been set to "FATAL" in the scope where C<$object>
557 is first used then die. Otherwise return.
558
559
560 =item warnings::warnif($message)
561
562 Equivalent to:
563
564     if (warnings::enabled())
565       { warnings::warn($message) }
566
567 =item warnings::warnif($category, $message)
568
569 Equivalent to:
570
571     if (warnings::enabled($category))
572       { warnings::warn($category, $message) }
573
574 =item warnings::warnif($object, $message)
575
576 Equivalent to:
577
578     if (warnings::enabled($object))
579       { warnings::warn($object, $message) }
580
581 =item warnings::register_categories(@names)
582
583 This registers warning categories for the given names and is primarily for
584 use by the warnings::register pragma, for which see L<perllexwarn>.
585
586 =back
587
588 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
589
590 =cut
591
592 KEYWORDS
593
594 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
595
596 sub Croaker
597 {
598     require Carp; # this initializes %CarpInternal
599     local $Carp::CarpInternal{'warnings'};
600     delete $Carp::CarpInternal{'warnings'};
601     Carp::croak(@_);
602 }
603
604 sub _bits {
605     my $mask = shift ;
606     my $catmask ;
607     my $fatal = 0 ;
608     my $no_fatal = 0 ;
609
610     foreach my $word ( @_ ) {
611         if ($word eq 'FATAL') {
612             $fatal = 1;
613             $no_fatal = 0;
614         }
615         elsif ($word eq 'NONFATAL') {
616             $fatal = 0;
617             $no_fatal = 1;
618         }
619         elsif ($catmask = $Bits{$word}) {
620             $mask |= $catmask ;
621             $mask |= $DeadBits{$word} if $fatal ;
622             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
623         }
624         else
625           { Croaker("Unknown warnings category '$word'")}
626     }
627
628     return $mask ;
629 }
630
631 sub bits
632 {
633     # called from B::Deparse.pm
634     push @_, 'all' unless @_ ;
635     return _bits(undef, @_) ;
636 }
637
638 sub import 
639 {
640     shift;
641
642     my $mask = ${^WARNING_BITS} ;
643
644     if (vec($mask, $Offsets{'all'}, 1)) {
645         $mask |= $Bits{'all'} ;
646         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
647     }
648     
649     # Empty @_ is equivalent to @_ = 'all' ;
650     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
651 }
652
653 sub unimport 
654 {
655     shift;
656
657     my $catmask ;
658     my $mask = ${^WARNING_BITS} ;
659
660     if (vec($mask, $Offsets{'all'}, 1)) {
661         $mask |= $Bits{'all'} ;
662         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
663     }
664
665     push @_, 'all' unless @_;
666
667     foreach my $word ( @_ ) {
668         if ($word eq 'FATAL') {
669             next; 
670         }
671         elsif ($catmask = $Bits{$word}) {
672             $mask &= ~($catmask | $DeadBits{$word} | $All);
673         }
674         else
675           { Croaker("Unknown warnings category '$word'")}
676     }
677
678     ${^WARNING_BITS} = $mask ;
679 }
680
681 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
682
683 sub MESSAGE () { 4 };
684 sub FATAL () { 2 };
685 sub NORMAL () { 1 };
686
687 sub __chk
688 {
689     my $category ;
690     my $offset ;
691     my $isobj = 0 ;
692     my $wanted = shift;
693     my $has_message = $wanted & MESSAGE;
694
695     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
696         my $sub = (caller 1)[3];
697         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
698         Croaker("Usage: $sub($syntax)");
699     }
700
701     my $message = pop if $has_message;
702
703     if (@_) {
704         # check the category supplied.
705         $category = shift ;
706         if (my $type = ref $category) {
707             Croaker("not an object")
708                 if exists $builtin_type{$type};
709             $category = $type;
710             $isobj = 1 ;
711         }
712         $offset = $Offsets{$category};
713         Croaker("Unknown warnings category '$category'")
714             unless defined $offset;
715     }
716     else {
717         $category = (caller(1))[0] ;
718         $offset = $Offsets{$category};
719         Croaker("package '$category' not registered for warnings")
720             unless defined $offset ;
721     }
722
723     my $i;
724
725     if ($isobj) {
726         my $pkg;
727         $i = 2;
728         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
729             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
730         }
731         $i -= 2 ;
732     }
733     else {
734         $i = _error_loc(); # see where Carp will allocate the error
735     }
736
737     # Defaulting this to 0 reduces complexity in code paths below.
738     my $callers_bitmask = (caller($i))[9] || 0 ;
739
740     my @results;
741     foreach my $type (FATAL, NORMAL) {
742         next unless $wanted & $type;
743
744         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
745                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
746     }
747
748     # &enabled and &fatal_enabled
749     return $results[0] unless $has_message;
750
751     # &warnif, and the category is neither enabled as warning nor as fatal
752     return if $wanted == (NORMAL | FATAL | MESSAGE)
753         && !($results[0] || $results[1]);
754
755     require Carp;
756     Carp::croak($message) if $results[0];
757     # will always get here for &warn. will only get here for &warnif if the
758     # category is enabled
759     Carp::carp($message);
760 }
761
762 sub _mkMask
763 {
764     my ($bit) = @_;
765     my $mask = "";
766
767     vec($mask, $bit, 1) = 1;
768     return $mask;
769 }
770
771 sub register_categories
772 {
773     my @names = @_;
774
775     for my $name (@names) {
776         if (! defined $Bits{$name}) {
777             $Bits{$name}     = _mkMask($LAST_BIT);
778             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
779             $Offsets{$name}  = $LAST_BIT ++;
780             foreach my $k (keys %Bits) {
781                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
782             }
783             $DeadBits{$name} = _mkMask($LAST_BIT);
784             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
785         }
786     }
787 }
788
789 sub _error_loc {
790     require Carp;
791     goto &Carp::short_error_loc; # don't introduce another stack frame
792 }
793
794 sub enabled
795 {
796     return __chk(NORMAL, @_);
797 }
798
799 sub fatal_enabled
800 {
801     return __chk(FATAL, @_);
802 }
803
804 sub warn
805 {
806     return __chk(FATAL | MESSAGE, @_);
807 }
808
809 sub warnif
810 {
811     return __chk(NORMAL | FATAL | MESSAGE, @_);
812 }
813
814 # These are not part of any public interface, so we can delete them to save
815 # space.
816 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
817
818 1;