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