This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen/warnings.pl: Add comments
[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
358 /* The w1, w2 ... should be independent warnings categories; one shouldn't be
359  * a subcategory of any other */
360
361 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
362 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
363 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
364
365 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
366 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
367 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
368 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
369
370 #define WARNshift               8
371
372 #define packWARN(a)             (a                                      )
373
374 /* The a, b, ... should be independent warnings categories; one shouldn't be
375  * a subcategory of any other */
376
377 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
378 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
379 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
380
381 #define unpackWARN1(x)          ((x)        & 0xFF)
382 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
383 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
384 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
385
386 #define ckDEAD(x)                                                       \
387            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
388             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
389               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
390               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
391               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
392               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
393
394 /* end of file warnings.h */
395 EOM
396
397 read_only_bottom_close_and_rename($warn);
398
399 while (<DATA>) {
400     last if /^KEYWORDS$/ ;
401     print $pm $_ ;
402 }
403
404 $last_ver = 0;
405 print $pm "our %Offsets = (\n" ;
406 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
407     my ($name, $version) = @{ $ValueToName{$k} };
408     $name = lc $name;
409     $k *= 2 ;
410     if ( $last_ver != $version ) {
411         print $pm "\n";
412         print $pm tab(4, "    # Warnings Categories added in Perl $version");
413         print $pm "\n\n";
414     }
415     print $pm tab(4, "    '$name'"), "=> $k,\n" ;
416     $last_ver = $version;
417 }
418
419 print $pm "  );\n\n" ;
420
421 print $pm "our %Bits = (\n" ;
422 foreach $k (sort keys  %list) {
423
424     my $v = $list{$k} ;
425     my @list = sort { $a <=> $b } @$v ;
426
427     print $pm tab(4, "    '$k'"), '=> "',
428                 mkHex($warn_size, map $_ * 2 , @list),
429                 '", # [', mkRange(@list), "]\n" ;
430 }
431
432 print $pm "  );\n\n" ;
433
434 print $pm "our %DeadBits = (\n" ;
435 foreach $k (sort keys  %list) {
436
437     my $v = $list{$k} ;
438     my @list = sort { $a <=> $b } @$v ;
439
440     print $pm tab(4, "    '$k'"), '=> "',
441                 mkHex($warn_size, map $_ * 2 + 1 , @list),
442                 '", # [', mkRange(@list), "]\n" ;
443 }
444
445 print $pm "  );\n\n" ;
446 print $pm '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
447 print $pm '$DEFAULT  = "', mkHex($warn_size, map $_ * 2, @def),
448                            '", # [', mkRange(@def), "]\n" ;
449 print $pm '$LAST_BIT = ' . "$index ;\n" ;
450 print $pm '$BYTES    = ' . "$warn_size ;\n" ;
451 while (<DATA>) {
452     print $pm $_ ;
453 }
454
455 read_only_bottom_close_and_rename($pm);
456
457 my $lexwarn = open_new 'pod/perllexwarn.pod', '>';
458 open my $oldlexwarn, "pod/perllexwarn.pod"
459   or die "$0 cannot open pod/perllexwarn.pod for reading: $!";
460 select +(select($lexwarn), do {
461     while(<$oldlexwarn>) {
462         print;
463         last if /=for warnings.pl begin/;
464     }
465     print "\n";
466     printTree($tree, "    ") ;
467     print "\n";
468     while(<$oldlexwarn>) {
469         last if /=for warnings.pl end/;
470     }
471     do { print } while <$oldlexwarn>;
472 })[0];
473
474 close_and_rename($lexwarn);
475
476 __END__
477 package warnings;
478
479 our $VERSION = '1.20';
480
481 # Verify that we're called correctly so that warnings will work.
482 # see also strict.pm.
483 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
484     my (undef, $f, $l) = caller;
485     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
486 }
487
488 =head1 NAME
489
490 warnings - Perl pragma to control optional warnings
491
492 =head1 SYNOPSIS
493
494     use warnings;
495     no warnings;
496
497     use warnings "all";
498     no warnings "all";
499
500     use warnings::register;
501     if (warnings::enabled()) {
502         warnings::warn("some warning");
503     }
504
505     if (warnings::enabled("void")) {
506         warnings::warn("void", "some warning");
507     }
508
509     if (warnings::enabled($object)) {
510         warnings::warn($object, "some warning");
511     }
512
513     warnings::warnif("some warning");
514     warnings::warnif("void", "some warning");
515     warnings::warnif($object, "some warning");
516
517 =head1 DESCRIPTION
518
519 The C<warnings> pragma is a replacement for the command line flag C<-w>,
520 but the pragma is limited to the enclosing block, while the flag is global.
521 See L<perllexwarn> for more information and the list of built-in warning
522 categories.
523
524 If no import list is supplied, all possible warnings are either enabled
525 or disabled.
526
527 A number of functions are provided to assist module authors.
528
529 =over 4
530
531 =item use warnings::register
532
533 Creates a new warnings category with the same name as the package where
534 the call to the pragma is used.
535
536 =item warnings::enabled()
537
538 Use the warnings category with the same name as the current package.
539
540 Return TRUE if that warnings category is enabled in the calling module.
541 Otherwise returns FALSE.
542
543 =item warnings::enabled($category)
544
545 Return TRUE if the warnings category, C<$category>, is enabled in the
546 calling module.
547 Otherwise returns FALSE.
548
549 =item warnings::enabled($object)
550
551 Use the name of the class for the object reference, C<$object>, as the
552 warnings category.
553
554 Return TRUE if that warnings category is enabled in the first scope
555 where the object is used.
556 Otherwise returns FALSE.
557
558 =item warnings::fatal_enabled()
559
560 Return TRUE if the warnings category with the same name as the current
561 package has been set to FATAL in the calling module.
562 Otherwise returns FALSE.
563
564 =item warnings::fatal_enabled($category)
565
566 Return TRUE if the warnings category C<$category> has been set to FATAL in
567 the calling module.
568 Otherwise returns FALSE.
569
570 =item warnings::fatal_enabled($object)
571
572 Use the name of the class for the object reference, C<$object>, as the
573 warnings category.
574
575 Return TRUE if that warnings category has been set to FATAL in the first
576 scope where the object is used.
577 Otherwise returns FALSE.
578
579 =item warnings::warn($message)
580
581 Print C<$message> to STDERR.
582
583 Use the warnings category with the same name as the current package.
584
585 If that warnings category has been set to "FATAL" in the calling module
586 then die. Otherwise return.
587
588 =item warnings::warn($category, $message)
589
590 Print C<$message> to STDERR.
591
592 If the warnings category, C<$category>, has been set to "FATAL" in the
593 calling module then die. Otherwise return.
594
595 =item warnings::warn($object, $message)
596
597 Print C<$message> to STDERR.
598
599 Use the name of the class for the object reference, C<$object>, as the
600 warnings category.
601
602 If that warnings category has been set to "FATAL" in the scope where C<$object>
603 is first used then die. Otherwise return.
604
605
606 =item warnings::warnif($message)
607
608 Equivalent to:
609
610     if (warnings::enabled())
611       { warnings::warn($message) }
612
613 =item warnings::warnif($category, $message)
614
615 Equivalent to:
616
617     if (warnings::enabled($category))
618       { warnings::warn($category, $message) }
619
620 =item warnings::warnif($object, $message)
621
622 Equivalent to:
623
624     if (warnings::enabled($object))
625       { warnings::warn($object, $message) }
626
627 =item warnings::register_categories(@names)
628
629 This registers warning categories for the given names and is primarily for
630 use by the warnings::register pragma, for which see L<perllexwarn>.
631
632 =back
633
634 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
635
636 =cut
637
638 KEYWORDS
639
640 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
641
642 sub Croaker
643 {
644     require Carp; # this initializes %CarpInternal
645     local $Carp::CarpInternal{'warnings'};
646     delete $Carp::CarpInternal{'warnings'};
647     Carp::croak(@_);
648 }
649
650 sub _bits {
651     my $mask = shift ;
652     my $catmask ;
653     my $fatal = 0 ;
654     my $no_fatal = 0 ;
655
656     foreach my $word ( @_ ) {
657         if ($word eq 'FATAL') {
658             $fatal = 1;
659             $no_fatal = 0;
660         }
661         elsif ($word eq 'NONFATAL') {
662             $fatal = 0;
663             $no_fatal = 1;
664         }
665         elsif ($catmask = $Bits{$word}) {
666             $mask |= $catmask ;
667             $mask |= $DeadBits{$word} if $fatal ;
668             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
669         }
670         else
671           { Croaker("Unknown warnings category '$word'")}
672     }
673
674     return $mask ;
675 }
676
677 sub bits
678 {
679     # called from B::Deparse.pm
680     push @_, 'all' unless @_ ;
681     return _bits(undef, @_) ;
682 }
683
684 sub import 
685 {
686     shift;
687
688     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
689
690     if (vec($mask, $Offsets{'all'}, 1)) {
691         $mask |= $Bits{'all'} ;
692         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
693     }
694     
695     # Empty @_ is equivalent to @_ = 'all' ;
696     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
697 }
698
699 sub unimport 
700 {
701     shift;
702
703     my $catmask ;
704     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
705
706     if (vec($mask, $Offsets{'all'}, 1)) {
707         $mask |= $Bits{'all'} ;
708         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
709     }
710
711     push @_, 'all' unless @_;
712
713     foreach my $word ( @_ ) {
714         if ($word eq 'FATAL') {
715             next; 
716         }
717         elsif ($catmask = $Bits{$word}) {
718             $mask &= ~($catmask | $DeadBits{$word} | $All);
719         }
720         else
721           { Croaker("Unknown warnings category '$word'")}
722     }
723
724     ${^WARNING_BITS} = $mask ;
725 }
726
727 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
728
729 sub MESSAGE () { 4 };
730 sub FATAL () { 2 };
731 sub NORMAL () { 1 };
732
733 sub __chk
734 {
735     my $category ;
736     my $offset ;
737     my $isobj = 0 ;
738     my $wanted = shift;
739     my $has_message = $wanted & MESSAGE;
740
741     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
742         my $sub = (caller 1)[3];
743         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
744         Croaker("Usage: $sub($syntax)");
745     }
746
747     my $message = pop if $has_message;
748
749     if (@_) {
750         # check the category supplied.
751         $category = shift ;
752         if (my $type = ref $category) {
753             Croaker("not an object")
754                 if exists $builtin_type{$type};
755             $category = $type;
756             $isobj = 1 ;
757         }
758         $offset = $Offsets{$category};
759         Croaker("Unknown warnings category '$category'")
760             unless defined $offset;
761     }
762     else {
763         $category = (caller(1))[0] ;
764         $offset = $Offsets{$category};
765         Croaker("package '$category' not registered for warnings")
766             unless defined $offset ;
767     }
768
769     my $i;
770
771     if ($isobj) {
772         my $pkg;
773         $i = 2;
774         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
775             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
776         }
777         $i -= 2 ;
778     }
779     else {
780         $i = _error_loc(); # see where Carp will allocate the error
781     }
782
783     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
784     # explicitly returns undef.
785     my(@callers_bitmask) = (caller($i))[9] ;
786     my $callers_bitmask =
787          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
788
789     my @results;
790     foreach my $type (FATAL, NORMAL) {
791         next unless $wanted & $type;
792
793         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
794                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
795     }
796
797     # &enabled and &fatal_enabled
798     return $results[0] unless $has_message;
799
800     # &warnif, and the category is neither enabled as warning nor as fatal
801     return if $wanted == (NORMAL | FATAL | MESSAGE)
802         && !($results[0] || $results[1]);
803
804     require Carp;
805     Carp::croak($message) if $results[0];
806     # will always get here for &warn. will only get here for &warnif if the
807     # category is enabled
808     Carp::carp($message);
809 }
810
811 sub _mkMask
812 {
813     my ($bit) = @_;
814     my $mask = "";
815
816     vec($mask, $bit, 1) = 1;
817     return $mask;
818 }
819
820 sub register_categories
821 {
822     my @names = @_;
823
824     for my $name (@names) {
825         if (! defined $Bits{$name}) {
826             $Bits{$name}     = _mkMask($LAST_BIT);
827             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
828             $Offsets{$name}  = $LAST_BIT ++;
829             foreach my $k (keys %Bits) {
830                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
831             }
832             $DeadBits{$name} = _mkMask($LAST_BIT);
833             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
834         }
835     }
836 }
837
838 sub _error_loc {
839     require Carp;
840     goto &Carp::short_error_loc; # don't introduce another stack frame
841 }
842
843 sub enabled
844 {
845     return __chk(NORMAL, @_);
846 }
847
848 sub fatal_enabled
849 {
850     return __chk(FATAL, @_);
851 }
852
853 sub warn
854 {
855     return __chk(FATAL | MESSAGE, @_);
856 }
857
858 sub warnif
859 {
860     return __chk(NORMAL | FATAL | MESSAGE, @_);
861 }
862
863 # These are not part of any public interface, so we can delete them to save
864 # space.
865 delete @warnings::{qw(NORMAL FATAL MESSAGE)};
866
867 1;