This patch with tests resolves CPAN RT #40727. The issue is an infi-
[perl.git] / 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_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");
266 my $pm = safer_open("lib/warnings.pm-new");
267
268 print $warn <<'EOM' ;
269 /* -*- buffer-read-only: t -*-
270    !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
271    This file is built by warnings.pl
272    Any changes made here will be lost!
273 */
274
275
276 #define Off(x)                  ((x) / 8)
277 #define Bit(x)                  (1 << ((x) % 8))
278 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
279
280
281 #define G_WARN_OFF              0       /* $^W == 0 */
282 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
283 #define G_WARN_ALL_ON           2       /* -W flag */
284 #define G_WARN_ALL_OFF          4       /* -X flag */
285 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
286 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
287
288 #define pWARN_STD               NULL
289 #define pWARN_ALL               (((STRLEN*)0)+1)    /* use warnings 'all' */
290 #define pWARN_NONE              (((STRLEN*)0)+2)    /* no  warnings 'all' */
291
292 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
293                                  (x) == pWARN_NONE)
294
295 /* if PL_warnhook is set to this value, then warnings die */
296 #define PERL_WARNHOOK_FATAL     (&PL_sv_placeholder)
297 EOM
298
299 my $offset = 0 ;
300
301 valueWalk ($tree) ;
302 my $index = orderValues();
303
304 die <<EOM if $index > 255 ;
305 Too many warnings categories -- max is 255
306     rewrite packWARN* & unpackWARN* macros 
307 EOM
308
309 walk ($tree) ;
310
311 $index *= 2 ;
312 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
313
314 my $k ;
315 my $last_ver = 0;
316 foreach $k (sort { $a <=> $b } keys %ValueToName) {
317     my ($name, $version) = @{ $ValueToName{$k} };
318     print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
319         if $last_ver != $version ;
320     print $warn tab(5, "#define WARN_$name"), "$k\n" ;
321     $last_ver = $version ;
322 }
323 print $warn "\n" ;
324
325 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
326 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
327 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
328 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
329
330 print $warn <<'EOM';
331
332 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
333 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
334 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
335 #define isWARN_on(c,x)  (IsSet((U8 *)(c + 1), 2*(x)))
336 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
337
338 #define DUP_WARNINGS(p)         \
339     (specialWARN(p) ? (STRLEN*)(p)      \
340     : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
341                                              char))
342
343 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
344 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
345 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
346 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
347
348 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
349 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
350 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
351 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
352
353 #define WARNshift               8
354
355 #define packWARN(a)             (a                                      )
356 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
357 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
358 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
359
360 #define unpackWARN1(x)          ((x)        & 0xFF)
361 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
362 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
363 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
364
365 #define ckDEAD(x)                                                       \
366            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
367             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
368               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
369               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
370               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
371               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
372
373 /* end of file warnings.h */
374 /* ex: set ro: */
375 EOM
376
377 safer_close $warn;
378 rename_if_different("warnings.h-new", "warnings.h");
379
380 while (<DATA>) {
381     last if /^KEYWORDS$/ ;
382     print $pm $_ ;
383 }
384
385 $last_ver = 0;
386 print $pm "our %Offsets = (\n" ;
387 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
388     my ($name, $version) = @{ $ValueToName{$k} };
389     $name = lc $name;
390     $k *= 2 ;
391     if ( $last_ver != $version ) {
392         print $pm "\n";
393         print $pm tab(4, "    # Warnings Categories added in Perl $version");
394         print $pm "\n\n";
395     }
396     print $pm tab(4, "    '$name'"), "=> $k,\n" ;
397     $last_ver = $version;
398 }
399
400 print $pm "  );\n\n" ;
401
402 print $pm "our %Bits = (\n" ;
403 foreach $k (sort keys  %list) {
404
405     my $v = $list{$k} ;
406     my @list = sort { $a <=> $b } @$v ;
407
408     print $pm tab(4, "    '$k'"), '=> "',
409                 mkHex($warn_size, map $_ * 2 , @list),
410                 '", # [', mkRange(@list), "]\n" ;
411 }
412
413 print $pm "  );\n\n" ;
414
415 print $pm "our %DeadBits = (\n" ;
416 foreach $k (sort keys  %list) {
417
418     my $v = $list{$k} ;
419     my @list = sort { $a <=> $b } @$v ;
420
421     print $pm tab(4, "    '$k'"), '=> "',
422                 mkHex($warn_size, map $_ * 2 + 1 , @list),
423                 '", # [', mkRange(@list), "]\n" ;
424 }
425
426 print $pm "  );\n\n" ;
427 print $pm '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
428 print $pm '$LAST_BIT = ' . "$index ;\n" ;
429 print $pm '$BYTES    = ' . "$warn_size ;\n" ;
430 while (<DATA>) {
431     print $pm $_ ;
432 }
433
434 print $pm "# ex: set ro:\n";
435 safer_close $pm;
436 rename_if_different("lib/warnings.pm-new", "lib/warnings.pm");
437
438 __END__
439 # -*- buffer-read-only: t -*-
440 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
441 # This file was created by warnings.pl
442 # Any changes made here will be lost.
443 #
444
445 package warnings;
446
447 our $VERSION = '1.11';
448
449 # Verify that we're called correctly so that warnings will work.
450 # see also strict.pm.
451 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
452     my (undef, $f, $l) = caller;
453     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
454 }
455
456 =head1 NAME
457
458 warnings - Perl pragma to control optional warnings
459
460 =head1 SYNOPSIS
461
462     use warnings;
463     no warnings;
464
465     use warnings "all";
466     no warnings "all";
467
468     use warnings::register;
469     if (warnings::enabled()) {
470         warnings::warn("some warning");
471     }
472
473     if (warnings::enabled("void")) {
474         warnings::warn("void", "some warning");
475     }
476
477     if (warnings::enabled($object)) {
478         warnings::warn($object, "some warning");
479     }
480
481     warnings::warnif("some warning");
482     warnings::warnif("void", "some warning");
483     warnings::warnif($object, "some warning");
484
485 =head1 DESCRIPTION
486
487 The C<warnings> pragma is a replacement for the command line flag C<-w>,
488 but the pragma is limited to the enclosing block, while the flag is global.
489 See L<perllexwarn> for more information.
490
491 If no import list is supplied, all possible warnings are either enabled
492 or disabled.
493
494 A number of functions are provided to assist module authors.
495
496 =over 4
497
498 =item use warnings::register
499
500 Creates a new warnings category with the same name as the package where
501 the call to the pragma is used.
502
503 =item warnings::enabled()
504
505 Use the warnings category with the same name as the current package.
506
507 Return TRUE if that warnings category is enabled in the calling module.
508 Otherwise returns FALSE.
509
510 =item warnings::enabled($category)
511
512 Return TRUE if the warnings category, C<$category>, is enabled in the
513 calling module.
514 Otherwise returns FALSE.
515
516 =item warnings::enabled($object)
517
518 Use the name of the class for the object reference, C<$object>, as the
519 warnings category.
520
521 Return TRUE if that warnings category is enabled in the first scope
522 where the object is used.
523 Otherwise returns FALSE.
524
525 =item warnings::fatal_enabled()
526
527 Return TRUE if the warnings category with the same name as the current
528 package has been set to FATAL in the calling module.
529 Otherwise returns FALSE.
530
531 =item warnings::fatal_enabled($category)
532
533 Return TRUE if the warnings category C<$category> has been set to FATAL in
534 the calling module.
535 Otherwise returns FALSE.
536
537 =item warnings::fatal_enabled($object)
538
539 Use the name of the class for the object reference, C<$object>, as the
540 warnings category.
541
542 Return TRUE if that warnings category has been set to FATAL in the first
543 scope where the object is used.
544 Otherwise returns FALSE.
545
546 =item warnings::warn($message)
547
548 Print C<$message> to STDERR.
549
550 Use the warnings category with the same name as the current package.
551
552 If that warnings category has been set to "FATAL" in the calling module
553 then die. Otherwise return.
554
555 =item warnings::warn($category, $message)
556
557 Print C<$message> to STDERR.
558
559 If the warnings category, C<$category>, has been set to "FATAL" in the
560 calling module then die. Otherwise return.
561
562 =item warnings::warn($object, $message)
563
564 Print C<$message> to STDERR.
565
566 Use the name of the class for the object reference, C<$object>, as the
567 warnings category.
568
569 If that warnings category has been set to "FATAL" in the scope where C<$object>
570 is first used then die. Otherwise return.
571
572
573 =item warnings::warnif($message)
574
575 Equivalent to:
576
577     if (warnings::enabled())
578       { warnings::warn($message) }
579
580 =item warnings::warnif($category, $message)
581
582 Equivalent to:
583
584     if (warnings::enabled($category))
585       { warnings::warn($category, $message) }
586
587 =item warnings::warnif($object, $message)
588
589 Equivalent to:
590
591     if (warnings::enabled($object))
592       { warnings::warn($object, $message) }
593
594 =item warnings::register_categories(@names)
595
596 This registers warning categories for the given names and is primarily for
597 use by the warnings::register pragma, for which see L<perllexwarn>.
598
599 =back
600
601 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
602
603 =cut
604
605 KEYWORDS
606
607 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
608
609 sub Croaker
610 {
611     require Carp; # this initializes %CarpInternal
612     local $Carp::CarpInternal{'warnings'};
613     delete $Carp::CarpInternal{'warnings'};
614     Carp::croak(@_);
615 }
616
617 sub _bits {
618     my $mask = shift ;
619     my $catmask ;
620     my $fatal = 0 ;
621     my $no_fatal = 0 ;
622
623     foreach my $word ( @_ ) {
624         if ($word eq 'FATAL') {
625             $fatal = 1;
626             $no_fatal = 0;
627         }
628         elsif ($word eq 'NONFATAL') {
629             $fatal = 0;
630             $no_fatal = 1;
631         }
632         elsif ($catmask = $Bits{$word}) {
633             $mask |= $catmask ;
634             $mask |= $DeadBits{$word} if $fatal ;
635             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
636         }
637         else
638           { Croaker("Unknown warnings category '$word'")}
639     }
640
641     return $mask ;
642 }
643
644 sub bits
645 {
646     # called from B::Deparse.pm
647     push @_, 'all' unless @_ ;
648     return _bits(undef, @_) ;
649 }
650
651 sub import 
652 {
653     shift;
654
655     my $mask = ${^WARNING_BITS} ;
656
657     if (vec($mask, $Offsets{'all'}, 1)) {
658         $mask |= $Bits{'all'} ;
659         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
660     }
661     
662     # Empty @_ is equivalent to @_ = 'all' ;
663     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
664 }
665
666 sub unimport 
667 {
668     shift;
669
670     my $catmask ;
671     my $mask = ${^WARNING_BITS} ;
672
673     if (vec($mask, $Offsets{'all'}, 1)) {
674         $mask |= $Bits{'all'} ;
675         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
676     }
677
678     push @_, 'all' unless @_;
679
680     foreach my $word ( @_ ) {
681         if ($word eq 'FATAL') {
682             next; 
683         }
684         elsif ($catmask = $Bits{$word}) {
685             $mask &= ~($catmask | $DeadBits{$word} | $All);
686         }
687         else
688           { Croaker("Unknown warnings category '$word'")}
689     }
690
691     ${^WARNING_BITS} = $mask ;
692 }
693
694 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
695
696 sub MESSAGE () { 4 };
697 sub FATAL () { 2 };
698 sub NORMAL () { 1 };
699
700 sub __chk
701 {
702     my $category ;
703     my $offset ;
704     my $isobj = 0 ;
705     my $wanted = shift;
706     my $has_message = $wanted & MESSAGE;
707
708     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
709         my $sub = (caller 1)[3];
710         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
711         Croaker("Usage: $sub($syntax)");
712     }
713
714     my $message = pop if $has_message;
715
716     if (@_) {
717         # check the category supplied.
718         $category = shift ;
719         if (my $type = ref $category) {
720             Croaker("not an object")
721                 if exists $builtin_type{$type};
722             $category = $type;
723             $isobj = 1 ;
724         }
725         $offset = $Offsets{$category};
726         Croaker("Unknown warnings category '$category'")
727             unless defined $offset;
728     }
729     else {
730         $category = (caller(1))[0] ;
731         $offset = $Offsets{$category};
732         Croaker("package '$category' not registered for warnings")
733             unless defined $offset ;
734     }
735
736     my $i;
737
738     if ($isobj) {
739         my $pkg;
740         $i = 2;
741         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
742             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
743         }
744         $i -= 2 ;
745     }
746     else {
747         $i = _error_loc(); # see where Carp will allocate the error
748     }
749
750     # Defaulting this to 0 reduces complexity in code paths below.
751     my $callers_bitmask = (caller($i))[9] || 0 ;
752
753     my @results;
754     foreach my $type (FATAL, NORMAL) {
755         next unless $wanted & $type;
756
757         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
758                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
759     }
760
761     # &enabled and &fatal_enabled
762     return $results[0] unless $has_message;
763
764     # &warnif, and the category is neither enabled as warning nor as fatal
765     return if $wanted == (NORMAL | FATAL | MESSAGE)
766         && !($results[0] || $results[1]);
767
768     require Carp;
769     Carp::croak($message) if $results[0];
770     # will always get here for &warn. will only get here for &warnif if the
771     # category is enabled
772     Carp::carp($message);
773 }
774
775 sub _mkMask
776 {
777     my ($bit) = @_;
778     my $mask = "";
779
780     vec($mask, $bit, 1) = 1;
781     return $mask;
782 }
783
784 sub register_categories
785 {
786     my @names = @_;
787
788     for my $name (@names) {
789         if (! defined $Bits{$name}) {
790             $Bits{$name}     = _mkMask($LAST_BIT);
791             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
792             $Offsets{$name}  = $LAST_BIT ++;
793             foreach my $k (keys %Bits) {
794                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
795             }
796             $DeadBits{$name} = _mkMask($LAST_BIT);
797             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
798         }
799     }
800 }
801
802 sub _error_loc {
803     require Carp;
804     goto &Carp::short_error_loc; # don't introduce another stack frame
805 }
806
807 sub enabled
808 {
809     return __chk(NORMAL, @_);
810 }
811
812 sub fatal_enabled
813 {
814     return __chk(FATAL, @_);
815 }
816
817 sub warn
818 {
819     return __chk(FATAL | MESSAGE, @_);
820 }
821
822 sub warnif
823 {
824     return __chk(NORMAL | FATAL | MESSAGE, @_);
825 }
826
827 # These are not part of any public interface, so we can delete them to save
828 # space.
829 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
830
831 1;