This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
replace ckWARN macros with functions
[perl5.git] / warnings.pl
1 #!/usr/bin/perl
2
3 $VERSION = '1.02_01';
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         'untie'         => [ 5.008, DEFAULT_OFF],
53         'substr'        => [ 5.008, DEFAULT_OFF],
54         'taint'         => [ 5.008, DEFAULT_OFF],
55         'signal'        => [ 5.008, DEFAULT_OFF],
56         'closure'       => [ 5.008, DEFAULT_OFF],
57         'overflow'      => [ 5.008, DEFAULT_OFF],
58         'portable'      => [ 5.008, DEFAULT_OFF],
59         'utf8'          => [ 5.008, DEFAULT_OFF],
60         'exiting'       => [ 5.008, DEFAULT_OFF],
61         'pack'          => [ 5.008, DEFAULT_OFF],
62         'unpack'        => [ 5.008, DEFAULT_OFF],
63         'threads'       => [ 5.008, DEFAULT_OFF],
64         'assertions'    => [ 5.009, DEFAULT_OFF],
65
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 binmode WARN;
256 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
257 binmode PM;
258
259 print WARN <<'EOM' ;
260 /* -*- buffer-read-only: t -*-
261    !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
262    This file is built by warnings.pl
263    Any changes made here will be lost!
264 */
265
266
267 #define Off(x)                  ((x) / 8)
268 #define Bit(x)                  (1 << ((x) % 8))
269 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
270
271
272 #define G_WARN_OFF              0       /* $^W == 0 */
273 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
274 #define G_WARN_ALL_ON           2       /* -W flag */
275 #define G_WARN_ALL_OFF          4       /* -X flag */
276 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
277 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
278
279 #define pWARN_STD               Nullsv
280 #define pWARN_ALL               (Nullsv+1)      /* use warnings 'all' */
281 #define pWARN_NONE              (Nullsv+2)      /* no  warnings 'all' */
282
283 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
284                                  (x) == pWARN_NONE)
285 EOM
286
287 my $offset = 0 ;
288
289 $index = $offset ;
290 #@{ $list{"all"} } = walk ($tree) ;
291 valueWalk ($tree) ;
292 my $index = orderValues();
293
294 die <<EOM if $index > 255 ;
295 Too many warnings categories -- max is 255
296     rewrite packWARN* & unpackWARN* macros 
297 EOM
298
299 walk ($tree) ;
300
301 $index *= 2 ;
302 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
303
304 my $k ;
305 my $last_ver = 0;
306 foreach $k (sort { $a <=> $b } keys %ValueToName) {
307     my ($name, $version) = @{ $ValueToName{$k} };
308     print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
309         if $last_ver != $version ;
310     print WARN tab(5, "#define WARN_$name"), "$k\n" ;
311     $last_ver = $version ;
312 }
313 print WARN "\n" ;
314
315 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
316 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
317 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
318 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
319 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
320
321 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
322
323 print WARN <<'EOM';
324
325 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
326 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
327 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
328 #define isWARN_on(c,x)  (IsSet(SvPVX_const(c), 2*(x)))
329 #define isWARNf_on(c,x) (IsSet(SvPVX_const(c), 2*(x)+1))
330
331 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
332 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
333 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
334 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
335
336 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
337 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
338 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
339 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
340
341 #define packWARN(a)             (a                                      )
342 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
343 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
344 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
345
346 #define unpackWARN1(x)          ((x)        & 0xFF)
347 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
348 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
349 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
350
351 #define ckDEAD(x)                                                       \
352            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
353             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
354               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
355               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
356               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
357               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
358
359 /* end of file warnings.h */
360 /* ex: set ro: */
361 EOM
362
363 close WARN ;
364
365 while (<DATA>) {
366     last if /^KEYWORDS$/ ;
367     print PM $_ ;
368 }
369
370 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
371
372 $last_ver = 0;
373 print PM "our %Offsets = (\n" ;
374 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
375     my ($name, $version) = @{ $ValueToName{$k} };
376     $name = lc $name;
377     $k *= 2 ;
378     if ( $last_ver != $version ) {
379         print PM "\n";
380         print PM tab(4, "    # Warnings Categories added in Perl $version");
381         print PM "\n\n";
382     }
383     print PM tab(4, "    '$name'"), "=> $k,\n" ;
384     $last_ver = $version;
385 }
386
387 print PM "  );\n\n" ;
388
389 print PM "our %Bits = (\n" ;
390 foreach $k (sort keys  %list) {
391
392     my $v = $list{$k} ;
393     my @list = sort { $a <=> $b } @$v ;
394
395     print PM tab(4, "    '$k'"), '=> "',
396                 # mkHex($warn_size, @list),
397                 mkHex($warn_size, map $_ * 2 , @list),
398                 '", # [', mkRange(@list), "]\n" ;
399 }
400
401 print PM "  );\n\n" ;
402
403 print PM "our %DeadBits = (\n" ;
404 foreach $k (sort keys  %list) {
405
406     my $v = $list{$k} ;
407     my @list = sort { $a <=> $b } @$v ;
408
409     print PM tab(4, "    '$k'"), '=> "',
410                 # mkHex($warn_size, @list),
411                 mkHex($warn_size, map $_ * 2 + 1 , @list),
412                 '", # [', mkRange(@list), "]\n" ;
413 }
414
415 print PM "  );\n\n" ;
416 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
417 print PM '$LAST_BIT = ' . "$index ;\n" ;
418 print PM '$BYTES    = ' . "$warn_size ;\n" ;
419 while (<DATA>) {
420     print PM $_ ;
421 }
422
423 print PM "# ex: set ro:\n";
424 close PM ;
425
426 __END__
427 # -*- buffer-read-only: t -*-
428 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
429 # This file was created by warnings.pl
430 # Any changes made here will be lost.
431 #
432
433 package warnings;
434
435 our $VERSION = '1.04';
436
437 =head1 NAME
438
439 warnings - Perl pragma to control optional warnings
440
441 =head1 SYNOPSIS
442
443     use warnings;
444     no warnings;
445
446     use warnings "all";
447     no warnings "all";
448
449     use warnings::register;
450     if (warnings::enabled()) {
451         warnings::warn("some warning");
452     }
453
454     if (warnings::enabled("void")) {
455         warnings::warn("void", "some warning");
456     }
457
458     if (warnings::enabled($object)) {
459         warnings::warn($object, "some warning");
460     }
461
462     warnings::warnif("some warning");
463     warnings::warnif("void", "some warning");
464     warnings::warnif($object, "some warning");
465
466 =head1 DESCRIPTION
467
468 The C<warnings> pragma is a replacement for the command line flag C<-w>,
469 but the pragma is limited to the enclosing block, while the flag is global.
470 See L<perllexwarn> for more information.
471
472 If no import list is supplied, all possible warnings are either enabled
473 or disabled.
474
475 A number of functions are provided to assist module authors.
476
477 =over 4
478
479 =item use warnings::register
480
481 Creates a new warnings category with the same name as the package where
482 the call to the pragma is used.
483
484 =item warnings::enabled()
485
486 Use the warnings category with the same name as the current package.
487
488 Return TRUE if that warnings category is enabled in the calling module.
489 Otherwise returns FALSE.
490
491 =item warnings::enabled($category)
492
493 Return TRUE if the warnings category, C<$category>, is enabled in the
494 calling module.
495 Otherwise returns FALSE.
496
497 =item warnings::enabled($object)
498
499 Use the name of the class for the object reference, C<$object>, as the
500 warnings category.
501
502 Return TRUE if that warnings category is enabled in the first scope
503 where the object is used.
504 Otherwise returns FALSE.
505
506 =item warnings::warn($message)
507
508 Print C<$message> to STDERR.
509
510 Use the warnings category with the same name as the current package.
511
512 If that warnings category has been set to "FATAL" in the calling module
513 then die. Otherwise return.
514
515 =item warnings::warn($category, $message)
516
517 Print C<$message> to STDERR.
518
519 If the warnings category, C<$category>, has been set to "FATAL" in the
520 calling module then die. Otherwise return.
521
522 =item warnings::warn($object, $message)
523
524 Print C<$message> to STDERR.
525
526 Use the name of the class for the object reference, C<$object>, as the
527 warnings category.
528
529 If that warnings category has been set to "FATAL" in the scope where C<$object>
530 is first used then die. Otherwise return.
531
532
533 =item warnings::warnif($message)
534
535 Equivalent to:
536
537     if (warnings::enabled())
538       { warnings::warn($message) }
539
540 =item warnings::warnif($category, $message)
541
542 Equivalent to:
543
544     if (warnings::enabled($category))
545       { warnings::warn($category, $message) }
546
547 =item warnings::warnif($object, $message)
548
549 Equivalent to:
550
551     if (warnings::enabled($object))
552       { warnings::warn($object, $message) }
553
554 =back
555
556 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
557
558 =cut
559
560 KEYWORDS
561
562 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
563
564 sub Croaker
565 {
566     require Carp::Heavy; # this initializes %CarpInternal
567     delete $Carp::CarpInternal{'warnings'};
568     Carp::croak(@_);
569 }
570
571 sub bits
572 {
573     # called from B::Deparse.pm
574
575     push @_, 'all' unless @_;
576
577     my $mask;
578     my $catmask ;
579     my $fatal = 0 ;
580     my $no_fatal = 0 ;
581
582     foreach my $word ( @_ ) {
583         if ($word eq 'FATAL') {
584             $fatal = 1;
585             $no_fatal = 0;
586         }
587         elsif ($word eq 'NONFATAL') {
588             $fatal = 0;
589             $no_fatal = 1;
590         }
591         elsif ($catmask = $Bits{$word}) {
592             $mask |= $catmask ;
593             $mask |= $DeadBits{$word} if $fatal ;
594             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
595         }
596         else
597           { Croaker("Unknown warnings category '$word'")}
598     }
599
600     return $mask ;
601 }
602
603 sub import 
604 {
605     shift;
606
607     my $catmask ;
608     my $fatal = 0 ;
609     my $no_fatal = 0 ;
610
611     my $mask = ${^WARNING_BITS} ;
612
613     if (vec($mask, $Offsets{'all'}, 1)) {
614         $mask |= $Bits{'all'} ;
615         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
616     }
617     
618     push @_, 'all' unless @_;
619
620     foreach my $word ( @_ ) {
621         if ($word eq 'FATAL') {
622             $fatal = 1;
623             $no_fatal = 0;
624         }
625         elsif ($word eq 'NONFATAL') {
626             $fatal = 0;
627             $no_fatal = 1;
628         }
629         elsif ($catmask = $Bits{$word}) {
630             $mask |= $catmask ;
631             $mask |= $DeadBits{$word} if $fatal ;
632             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
633         }
634         else
635           { Croaker("Unknown warnings category '$word'")}
636     }
637
638     ${^WARNING_BITS} = $mask ;
639 }
640
641 sub unimport 
642 {
643     shift;
644
645     my $catmask ;
646     my $mask = ${^WARNING_BITS} ;
647
648     if (vec($mask, $Offsets{'all'}, 1)) {
649         $mask |= $Bits{'all'} ;
650         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
651     }
652
653     push @_, 'all' unless @_;
654
655     foreach my $word ( @_ ) {
656         if ($word eq 'FATAL') {
657             next; 
658         }
659         elsif ($catmask = $Bits{$word}) {
660             $mask &= ~($catmask | $DeadBits{$word} | $All);
661         }
662         else
663           { Croaker("Unknown warnings category '$word'")}
664     }
665
666     ${^WARNING_BITS} = $mask ;
667 }
668
669 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
670
671 sub __chk
672 {
673     my $category ;
674     my $offset ;
675     my $isobj = 0 ;
676
677     if (@_) {
678         # check the category supplied.
679         $category = shift ;
680         if (my $type = ref $category) {
681             Croaker("not an object")
682                 if exists $builtin_type{$type};
683             $category = $type;
684             $isobj = 1 ;
685         }
686         $offset = $Offsets{$category};
687         Croaker("Unknown warnings category '$category'")
688             unless defined $offset;
689     }
690     else {
691         $category = (caller(1))[0] ;
692         $offset = $Offsets{$category};
693         Croaker("package '$category' not registered for warnings")
694             unless defined $offset ;
695     }
696
697     my $this_pkg = (caller(1))[0] ;
698     my $i = 2 ;
699     my $pkg ;
700
701     if ($isobj) {
702         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
703             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
704         }
705         $i -= 2 ;
706     }
707     else {
708         $i = _error_loc(); # see where Carp will allocate the error
709     }
710
711     my $callers_bitmask = (caller($i))[9] ;
712     return ($callers_bitmask, $offset, $i) ;
713 }
714
715 sub _error_loc {
716     require Carp::Heavy;
717     goto &Carp::short_error_loc; # don't introduce another stack frame
718 }                                                             
719
720 sub enabled
721 {
722     Croaker("Usage: warnings::enabled([category])")
723         unless @_ == 1 || @_ == 0 ;
724
725     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
726
727     return 0 unless defined $callers_bitmask ;
728     return vec($callers_bitmask, $offset, 1) ||
729            vec($callers_bitmask, $Offsets{'all'}, 1) ;
730 }
731
732
733 sub warn
734 {
735     Croaker("Usage: warnings::warn([category,] 'message')")
736         unless @_ == 2 || @_ == 1 ;
737
738     my $message = pop ;
739     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
740     require Carp;
741     Carp::croak($message)
742         if vec($callers_bitmask, $offset+1, 1) ||
743            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
744     Carp::carp($message) ;
745 }
746
747 sub warnif
748 {
749     Croaker("Usage: warnings::warnif([category,] 'message')")
750         unless @_ == 2 || @_ == 1 ;
751
752     my $message = pop ;
753     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
754
755     return
756         unless defined $callers_bitmask &&
757                 (vec($callers_bitmask, $offset, 1) ||
758                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
759
760     require Carp;
761     Carp::croak($message)
762         if vec($callers_bitmask, $offset+1, 1) ||
763            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
764
765     Carp::carp($message) ;
766 }
767
768 1;