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