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