Re: [PATCH] Fix overloading for 64-bit ints (revised)
[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
65          #'default'     => [ 5.008, DEFAULT_ON ],
66         }],
67 } ;
68
69 ###########################################################################
70 sub tab {
71     my($l, $t) = @_;
72     $t .= "\t" x ($l - (length($t) + 1) / 8);
73     $t;
74 }
75
76 ###########################################################################
77
78 my %list ;
79 my %Value ;
80 my %ValueToName ;
81 my %NameToValue ;
82 my $index ;
83
84 my %v_list = () ;
85
86 sub valueWalk
87 {
88     my $tre = shift ;
89     my @list = () ;
90     my ($k, $v) ;
91
92     foreach $k (sort keys %$tre) {
93         $v = $tre->{$k};
94         die "duplicate key $k\n" if defined $list{$k} ;
95         die "Value associated with key '$k' is not an ARRAY reference"
96             if !ref $v || ref $v ne 'ARRAY' ;
97
98         my ($ver, $rest) = @{ $v } ;
99         push @{ $v_list{$ver} }, $k;
100         
101         if (ref $rest)
102           { valueWalk ($rest) }
103
104     }
105
106 }
107
108 sub orderValues
109 {
110     my $index = 0;
111     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
112         foreach my $name (@{ $v_list{$ver} } ) {
113             $ValueToName{ $index } = [ uc $name, $ver ] ;
114             $NameToValue{ uc $name } = $index ++ ;
115         }
116     }
117
118     return $index ;
119 }
120
121 ###########################################################################
122
123 sub walk
124 {
125     my $tre = shift ;
126     my @list = () ;
127     my ($k, $v) ;
128
129     foreach $k (sort keys %$tre) {
130         $v = $tre->{$k};
131         die "duplicate key $k\n" if defined $list{$k} ;
132         #$Value{$index} = uc $k ;
133         die "Can't find key '$k'"
134             if ! defined $NameToValue{uc $k} ;
135         push @{ $list{$k} }, $NameToValue{uc $k} ;
136         die "Value associated with key '$k' is not an ARRAY reference"
137             if !ref $v || ref $v ne 'ARRAY' ;
138         
139         my ($ver, $rest) = @{ $v } ;
140         if (ref $rest)
141           { push (@{ $list{$k} }, walk ($rest)) }
142
143         push @list, @{ $list{$k} } ;
144     }
145
146    return @list ;
147 }
148
149 ###########################################################################
150
151 sub mkRange
152 {
153     my @a = @_ ;
154     my @out = @a ;
155     my $i ;
156
157
158     for ($i = 1 ; $i < @a; ++ $i) {
159         $out[$i] = ".."
160           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
161     }
162
163     my $out = join(",",@out);
164
165     $out =~ s/,(\.\.,)+/../g ;
166     return $out;
167 }
168
169 ###########################################################################
170 sub printTree
171 {
172     my $tre = shift ;
173     my $prefix = shift ;
174     my ($k, $v) ;
175
176     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
177     my @keys = sort keys %$tre ;
178
179     while ($k = shift @keys) {
180         $v = $tre->{$k};
181         die "Value associated with key '$k' is not an ARRAY reference"
182             if !ref $v || ref $v ne 'ARRAY' ;
183         
184         my $offset ;
185         if ($tre ne $tree) {
186             print $prefix . "|\n" ;
187             print $prefix . "+- $k" ;
188             $offset = ' ' x ($max + 4) ;
189         }
190         else {
191             print $prefix . "$k" ;
192             $offset = ' ' x ($max + 1) ;
193         }
194
195         my ($ver, $rest) = @{ $v } ;
196         if (ref $rest)
197         {
198             my $bar = @keys ? "|" : " ";
199             print " -" . "-" x ($max - length $k ) . "+\n" ;
200             printTree ($rest, $prefix . $bar . $offset )
201         }
202         else
203           { print "\n" }
204     }
205
206 }
207
208 ###########################################################################
209
210 sub mkHexOct
211 {
212     my ($f, $max, @a) = @_ ;
213     my $mask = "\x00" x $max ;
214     my $string = "" ;
215
216     foreach (@a) {
217         vec($mask, $_, 1) = 1 ;
218     }
219
220     foreach (unpack("C*", $mask)) {
221         if ($f eq 'x') {
222             $string .= '\x' . sprintf("%2.2x", $_)
223         }
224         else {
225             $string .= '\\' . sprintf("%o", $_)
226         }
227     }
228     return $string ;
229 }
230
231 sub mkHex
232 {
233     my($max, @a) = @_;
234     return mkHexOct("x", $max, @a);
235 }
236
237 sub mkOct
238 {
239     my($max, @a) = @_;
240     return mkHexOct("o", $max, @a);
241 }
242
243 ###########################################################################
244
245 if (@ARGV && $ARGV[0] eq "tree")
246 {
247     printTree($tree, "    ") ;
248     exit ;
249 }
250
251 unlink "warnings.h";
252 unlink "lib/warnings.pm";
253 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
254 binmode WARN;
255 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
256 binmode PM;
257
258 print WARN <<'EOM' ;
259 /* -*- buffer-read-only: t -*-
260    !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
261    This file is built by warnings.pl
262    Any changes made here will be lost!
263 */
264
265
266 #define Off(x)                  ((x) / 8)
267 #define Bit(x)                  (1 << ((x) % 8))
268 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
269
270
271 #define G_WARN_OFF              0       /* $^W == 0 */
272 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
273 #define G_WARN_ALL_ON           2       /* -W flag */
274 #define G_WARN_ALL_OFF          4       /* -X flag */
275 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
276 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
277
278 #define pWARN_STD               NULL
279 #define pWARN_ALL               (((STRLEN*)0)+1)    /* use warnings 'all' */
280 #define pWARN_NONE              (((STRLEN*)0)+2)    /* no  warnings 'all' */
281
282 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
283                                  (x) == pWARN_NONE)
284
285 /* if PL_warnhook is set to this value, then warnings die */
286 #define PERL_WARNHOOK_FATAL     (&PL_sv_placeholder)
287 EOM
288
289 my $offset = 0 ;
290
291 $index = $offset ;
292 #@{ $list{"all"} } = walk ($tree) ;
293 valueWalk ($tree) ;
294 my $index = orderValues();
295
296 die <<EOM if $index > 255 ;
297 Too many warnings categories -- max is 255
298     rewrite packWARN* & unpackWARN* macros 
299 EOM
300
301 walk ($tree) ;
302
303 $index *= 2 ;
304 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
305
306 my $k ;
307 my $last_ver = 0;
308 foreach $k (sort { $a <=> $b } keys %ValueToName) {
309     my ($name, $version) = @{ $ValueToName{$k} };
310     print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
311         if $last_ver != $version ;
312     print WARN tab(5, "#define WARN_$name"), "$k\n" ;
313     $last_ver = $version ;
314 }
315 print WARN "\n" ;
316
317 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
318 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
319 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
320 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
321
322 print WARN <<'EOM';
323
324 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
325 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
326 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
327 #define isWARN_on(c,x)  (IsSet((U8 *)(c + 1), 2*(x)))
328 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
329
330 #define DUP_WARNINGS(p)         \
331     (specialWARN(p) ? (STRLEN*)(p)      \
332     : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
333                                              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.06';
440
441 # Verify that we're called correctly so that warnings will work.
442 # see also strict.pm.
443 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
444     my (undef, $f, $l) = caller;
445     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
446 }
447
448 =head1 NAME
449
450 warnings - Perl pragma to control optional warnings
451
452 =head1 SYNOPSIS
453
454     use warnings;
455     no warnings;
456
457     use warnings "all";
458     no warnings "all";
459
460     use warnings::register;
461     if (warnings::enabled()) {
462         warnings::warn("some warning");
463     }
464
465     if (warnings::enabled("void")) {
466         warnings::warn("void", "some warning");
467     }
468
469     if (warnings::enabled($object)) {
470         warnings::warn($object, "some warning");
471     }
472
473     warnings::warnif("some warning");
474     warnings::warnif("void", "some warning");
475     warnings::warnif($object, "some warning");
476
477 =head1 DESCRIPTION
478
479 The C<warnings> pragma is a replacement for the command line flag C<-w>,
480 but the pragma is limited to the enclosing block, while the flag is global.
481 See L<perllexwarn> for more information.
482
483 If no import list is supplied, all possible warnings are either enabled
484 or disabled.
485
486 A number of functions are provided to assist module authors.
487
488 =over 4
489
490 =item use warnings::register
491
492 Creates a new warnings category with the same name as the package where
493 the call to the pragma is used.
494
495 =item warnings::enabled()
496
497 Use the warnings category with the same name as the current package.
498
499 Return TRUE if that warnings category is enabled in the calling module.
500 Otherwise returns FALSE.
501
502 =item warnings::enabled($category)
503
504 Return TRUE if the warnings category, C<$category>, is enabled in the
505 calling module.
506 Otherwise returns FALSE.
507
508 =item warnings::enabled($object)
509
510 Use the name of the class for the object reference, C<$object>, as the
511 warnings category.
512
513 Return TRUE if that warnings category is enabled in the first scope
514 where the object is used.
515 Otherwise returns FALSE.
516
517 =item warnings::warn($message)
518
519 Print C<$message> to STDERR.
520
521 Use the warnings category with the same name as the current package.
522
523 If that warnings category has been set to "FATAL" in the calling module
524 then die. Otherwise return.
525
526 =item warnings::warn($category, $message)
527
528 Print C<$message> to STDERR.
529
530 If the warnings category, C<$category>, has been set to "FATAL" in the
531 calling module then die. Otherwise return.
532
533 =item warnings::warn($object, $message)
534
535 Print C<$message> to STDERR.
536
537 Use the name of the class for the object reference, C<$object>, as the
538 warnings category.
539
540 If that warnings category has been set to "FATAL" in the scope where C<$object>
541 is first used then die. Otherwise return.
542
543
544 =item warnings::warnif($message)
545
546 Equivalent to:
547
548     if (warnings::enabled())
549       { warnings::warn($message) }
550
551 =item warnings::warnif($category, $message)
552
553 Equivalent to:
554
555     if (warnings::enabled($category))
556       { warnings::warn($category, $message) }
557
558 =item warnings::warnif($object, $message)
559
560 Equivalent to:
561
562     if (warnings::enabled($object))
563       { warnings::warn($object, $message) }
564
565 =back
566
567 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
568
569 =cut
570
571 KEYWORDS
572
573 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
574
575 sub Croaker
576 {
577     require Carp::Heavy; # this initializes %CarpInternal
578     local $Carp::CarpInternal{'warnings'};
579     delete $Carp::CarpInternal{'warnings'};
580     Carp::croak(@_);
581 }
582
583 sub bits
584 {
585     # called from B::Deparse.pm
586
587     push @_, 'all' unless @_;
588
589     my $mask;
590     my $catmask ;
591     my $fatal = 0 ;
592     my $no_fatal = 0 ;
593
594     foreach my $word ( @_ ) {
595         if ($word eq 'FATAL') {
596             $fatal = 1;
597             $no_fatal = 0;
598         }
599         elsif ($word eq 'NONFATAL') {
600             $fatal = 0;
601             $no_fatal = 1;
602         }
603         elsif ($catmask = $Bits{$word}) {
604             $mask |= $catmask ;
605             $mask |= $DeadBits{$word} if $fatal ;
606             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
607         }
608         else
609           { Croaker("Unknown warnings category '$word'")}
610     }
611
612     return $mask ;
613 }
614
615 sub import 
616 {
617     shift;
618
619     my $catmask ;
620     my $fatal = 0 ;
621     my $no_fatal = 0 ;
622
623     my $mask = ${^WARNING_BITS} ;
624
625     if (vec($mask, $Offsets{'all'}, 1)) {
626         $mask |= $Bits{'all'} ;
627         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
628     }
629     
630     push @_, 'all' unless @_;
631
632     foreach my $word ( @_ ) {
633         if ($word eq 'FATAL') {
634             $fatal = 1;
635             $no_fatal = 0;
636         }
637         elsif ($word eq 'NONFATAL') {
638             $fatal = 0;
639             $no_fatal = 1;
640         }
641         elsif ($catmask = $Bits{$word}) {
642             $mask |= $catmask ;
643             $mask |= $DeadBits{$word} if $fatal ;
644             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
645         }
646         else
647           { Croaker("Unknown warnings category '$word'")}
648     }
649
650     ${^WARNING_BITS} = $mask ;
651 }
652
653 sub unimport 
654 {
655     shift;
656
657     my $catmask ;
658     my $mask = ${^WARNING_BITS} ;
659
660     if (vec($mask, $Offsets{'all'}, 1)) {
661         $mask |= $Bits{'all'} ;
662         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
663     }
664
665     push @_, 'all' unless @_;
666
667     foreach my $word ( @_ ) {
668         if ($word eq 'FATAL') {
669             next; 
670         }
671         elsif ($catmask = $Bits{$word}) {
672             $mask &= ~($catmask | $DeadBits{$word} | $All);
673         }
674         else
675           { Croaker("Unknown warnings category '$word'")}
676     }
677
678     ${^WARNING_BITS} = $mask ;
679 }
680
681 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
682
683 sub __chk
684 {
685     my $category ;
686     my $offset ;
687     my $isobj = 0 ;
688
689     if (@_) {
690         # check the category supplied.
691         $category = shift ;
692         if (my $type = ref $category) {
693             Croaker("not an object")
694                 if exists $builtin_type{$type};
695             $category = $type;
696             $isobj = 1 ;
697         }
698         $offset = $Offsets{$category};
699         Croaker("Unknown warnings category '$category'")
700             unless defined $offset;
701     }
702     else {
703         $category = (caller(1))[0] ;
704         $offset = $Offsets{$category};
705         Croaker("package '$category' not registered for warnings")
706             unless defined $offset ;
707     }
708
709     my $this_pkg = (caller(1))[0] ;
710     my $i = 2 ;
711     my $pkg ;
712
713     if ($isobj) {
714         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
715             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
716         }
717         $i -= 2 ;
718     }
719     else {
720         $i = _error_loc(); # see where Carp will allocate the error
721     }
722
723     my $callers_bitmask = (caller($i))[9] ;
724     return ($callers_bitmask, $offset, $i) ;
725 }
726
727 sub _error_loc {
728     require Carp::Heavy;
729     goto &Carp::short_error_loc; # don't introduce another stack frame
730 }                                                             
731
732 sub enabled
733 {
734     Croaker("Usage: warnings::enabled([category])")
735         unless @_ == 1 || @_ == 0 ;
736
737     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
738
739     return 0 unless defined $callers_bitmask ;
740     return vec($callers_bitmask, $offset, 1) ||
741            vec($callers_bitmask, $Offsets{'all'}, 1) ;
742 }
743
744
745 sub warn
746 {
747     Croaker("Usage: warnings::warn([category,] 'message')")
748         unless @_ == 2 || @_ == 1 ;
749
750     my $message = pop ;
751     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
752     require Carp;
753     Carp::croak($message)
754         if vec($callers_bitmask, $offset+1, 1) ||
755            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
756     Carp::carp($message) ;
757 }
758
759 sub warnif
760 {
761     Croaker("Usage: warnings::warnif([category,] 'message')")
762         unless @_ == 2 || @_ == 1 ;
763
764     my $message = pop ;
765     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
766
767     return
768         unless defined $callers_bitmask &&
769                 (vec($callers_bitmask, $offset, 1) ||
770                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
771
772     require Carp;
773     Carp::croak($message)
774         if vec($callers_bitmask, $offset+1, 1) ||
775            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
776
777     Carp::carp($message) ;
778 }
779
780 1;