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