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