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