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