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