RE: [PATCH] compress 2.018
[p5sagit/p5-mst-13.2.git] / warnings.pl
1 #!/usr/bin/perl
2
3 $VERSION = '1.02_02';
4
5 BEGIN {
6     require 'regen_lib.pl';
7     push @INC, './lib';
8 }
9 use strict ;
10
11 sub DEFAULT_ON  () { 1 }
12 sub DEFAULT_OFF () { 2 }
13
14 my $tree = {
15
16 'all' => [ 5.008, {
17         'io'            => [ 5.008, {   
18                                 'pipe'          => [ 5.008, DEFAULT_OFF],
19                                 'unopened'      => [ 5.008, DEFAULT_OFF],
20                                 'closed'        => [ 5.008, DEFAULT_OFF],
21                                 'newline'       => [ 5.008, DEFAULT_OFF],
22                                 'exec'          => [ 5.008, DEFAULT_OFF],
23                                 'layer'         => [ 5.008, DEFAULT_OFF],
24                            }],
25         'syntax'        => [ 5.008, {   
26                                 'ambiguous'     => [ 5.008, DEFAULT_OFF],
27                                 'semicolon'     => [ 5.008, DEFAULT_OFF],
28                                 'precedence'    => [ 5.008, DEFAULT_OFF],
29                                 'bareword'      => [ 5.008, DEFAULT_OFF],
30                                 'reserved'      => [ 5.008, DEFAULT_OFF],
31                                 'digit'         => [ 5.008, DEFAULT_OFF],
32                                 'parenthesis'   => [ 5.008, DEFAULT_OFF],
33                                 'printf'        => [ 5.008, DEFAULT_OFF],
34                                 'prototype'     => [ 5.008, DEFAULT_OFF],
35                                 'qw'            => [ 5.008, DEFAULT_OFF],
36                            }],
37         'severe'        => [ 5.008, {   
38                                 'inplace'       => [ 5.008, DEFAULT_ON],
39                                 'internal'      => [ 5.008, DEFAULT_ON],
40                                 'debugging'     => [ 5.008, DEFAULT_ON],
41                                 'malloc'        => [ 5.008, DEFAULT_ON],
42                            }],
43         'deprecated'    => [ 5.008, DEFAULT_OFF],
44         'void'          => [ 5.008, DEFAULT_OFF],
45         'recursion'     => [ 5.008, DEFAULT_OFF],
46         'redefine'      => [ 5.008, DEFAULT_OFF],
47         'numeric'       => [ 5.008, DEFAULT_OFF],
48         'uninitialized' => [ 5.008, DEFAULT_OFF],
49         'once'          => [ 5.008, DEFAULT_OFF],
50         'misc'          => [ 5.008, DEFAULT_OFF],
51         'regexp'        => [ 5.008, DEFAULT_OFF],
52         'glob'          => [ 5.008, DEFAULT_OFF],
53         'untie'         => [ 5.008, DEFAULT_OFF],
54         'substr'        => [ 5.008, DEFAULT_OFF],
55         'taint'         => [ 5.008, DEFAULT_OFF],
56         'signal'        => [ 5.008, DEFAULT_OFF],
57         'closure'       => [ 5.008, DEFAULT_OFF],
58         'overflow'      => [ 5.008, DEFAULT_OFF],
59         'portable'      => [ 5.008, DEFAULT_OFF],
60         'utf8'          => [ 5.008, DEFAULT_OFF],
61         'exiting'       => [ 5.008, DEFAULT_OFF],
62         'pack'          => [ 5.008, DEFAULT_OFF],
63         'unpack'        => [ 5.008, DEFAULT_OFF],
64         'threads'       => [ 5.008, DEFAULT_OFF],
65         'imprecision'   => [ 5.011, DEFAULT_OFF],
66
67          #'default'     => [ 5.008, DEFAULT_ON ],
68         }],
69 } ;
70
71 ###########################################################################
72 sub tab {
73     my($l, $t) = @_;
74     $t .= "\t" x ($l - (length($t) + 1) / 8);
75     $t;
76 }
77
78 ###########################################################################
79
80 my %list ;
81 my %Value ;
82 my %ValueToName ;
83 my %NameToValue ;
84 my $index ;
85
86 my %v_list = () ;
87
88 sub valueWalk
89 {
90     my $tre = shift ;
91     my @list = () ;
92     my ($k, $v) ;
93
94     foreach $k (sort keys %$tre) {
95         $v = $tre->{$k};
96         die "duplicate key $k\n" if defined $list{$k} ;
97         die "Value associated with key '$k' is not an ARRAY reference"
98             if !ref $v || ref $v ne 'ARRAY' ;
99
100         my ($ver, $rest) = @{ $v } ;
101         push @{ $v_list{$ver} }, $k;
102         
103         if (ref $rest)
104           { valueWalk ($rest) }
105
106     }
107
108 }
109
110 sub orderValues
111 {
112     my $index = 0;
113     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
114         foreach my $name (@{ $v_list{$ver} } ) {
115             $ValueToName{ $index } = [ uc $name, $ver ] ;
116             $NameToValue{ uc $name } = $index ++ ;
117         }
118     }
119
120     return $index ;
121 }
122
123 ###########################################################################
124
125 sub walk
126 {
127     my $tre = shift ;
128     my @list = () ;
129     my ($k, $v) ;
130
131     foreach $k (sort keys %$tre) {
132         $v = $tre->{$k};
133         die "duplicate key $k\n" if defined $list{$k} ;
134         #$Value{$index} = uc $k ;
135         die "Can't find key '$k'"
136             if ! defined $NameToValue{uc $k} ;
137         push @{ $list{$k} }, $NameToValue{uc $k} ;
138         die "Value associated with key '$k' is not an ARRAY reference"
139             if !ref $v || ref $v ne 'ARRAY' ;
140         
141         my ($ver, $rest) = @{ $v } ;
142         if (ref $rest)
143           { push (@{ $list{$k} }, walk ($rest)) }
144
145         push @list, @{ $list{$k} } ;
146     }
147
148    return @list ;
149 }
150
151 ###########################################################################
152
153 sub mkRange
154 {
155     my @a = @_ ;
156     my @out = @a ;
157     my $i ;
158
159
160     for ($i = 1 ; $i < @a; ++ $i) {
161         $out[$i] = ".."
162           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
163     }
164
165     my $out = join(",",@out);
166
167     $out =~ s/,(\.\.,)+/../g ;
168     return $out;
169 }
170
171 ###########################################################################
172 sub printTree
173 {
174     my $tre = shift ;
175     my $prefix = shift ;
176     my ($k, $v) ;
177
178     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
179     my @keys = sort keys %$tre ;
180
181     while ($k = shift @keys) {
182         $v = $tre->{$k};
183         die "Value associated with key '$k' is not an ARRAY reference"
184             if !ref $v || ref $v ne 'ARRAY' ;
185         
186         my $offset ;
187         if ($tre ne $tree) {
188             print $prefix . "|\n" ;
189             print $prefix . "+- $k" ;
190             $offset = ' ' x ($max + 4) ;
191         }
192         else {
193             print $prefix . "$k" ;
194             $offset = ' ' x ($max + 1) ;
195         }
196
197         my ($ver, $rest) = @{ $v } ;
198         if (ref $rest)
199         {
200             my $bar = @keys ? "|" : " ";
201             print " -" . "-" x ($max - length $k ) . "+\n" ;
202             printTree ($rest, $prefix . $bar . $offset )
203         }
204         else
205           { print "\n" }
206     }
207
208 }
209
210 ###########################################################################
211
212 sub mkHexOct
213 {
214     my ($f, $max, @a) = @_ ;
215     my $mask = "\x00" x $max ;
216     my $string = "" ;
217
218     foreach (@a) {
219         vec($mask, $_, 1) = 1 ;
220     }
221
222     foreach (unpack("C*", $mask)) {
223         if ($f eq 'x') {
224             $string .= '\x' . sprintf("%2.2x", $_)
225         }
226         else {
227             $string .= '\\' . sprintf("%o", $_)
228         }
229     }
230     return $string ;
231 }
232
233 sub mkHex
234 {
235     my($max, @a) = @_;
236     return mkHexOct("x", $max, @a);
237 }
238
239 sub mkOct
240 {
241     my($max, @a) = @_;
242     return mkHexOct("o", $max, @a);
243 }
244
245 ###########################################################################
246
247 if (@ARGV && $ARGV[0] eq "tree")
248 {
249     printTree($tree, "    ") ;
250     exit ;
251 }
252
253 my $warn = safer_open("warnings.h-new");
254 my $pm = safer_open("lib/warnings.pm-new");
255
256 print $warn <<'EOM' ;
257 /* -*- buffer-read-only: t -*-
258    !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
259    This file is built by warnings.pl
260    Any changes made here will be lost!
261 */
262
263
264 #define Off(x)                  ((x) / 8)
265 #define Bit(x)                  (1 << ((x) % 8))
266 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
267
268
269 #define G_WARN_OFF              0       /* $^W == 0 */
270 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
271 #define G_WARN_ALL_ON           2       /* -W flag */
272 #define G_WARN_ALL_OFF          4       /* -X flag */
273 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
274 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
275
276 #define pWARN_STD               NULL
277 #define pWARN_ALL               (((STRLEN*)0)+1)    /* use warnings 'all' */
278 #define pWARN_NONE              (((STRLEN*)0)+2)    /* no  warnings 'all' */
279
280 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
281                                  (x) == pWARN_NONE)
282
283 /* if PL_warnhook is set to this value, then warnings die */
284 #define PERL_WARNHOOK_FATAL     (&PL_sv_placeholder)
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
320 print $warn <<'EOM';
321
322 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
323 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
324 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
325 #define isWARN_on(c,x)  (IsSet((U8 *)(c + 1), 2*(x)))
326 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
327
328 #define DUP_WARNINGS(p)         \
329     (specialWARN(p) ? (STRLEN*)(p)      \
330     : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
331                                              char))
332
333 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
334 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
335 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
336 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
337
338 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
339 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
340 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
341 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
342
343 #define packWARN(a)             (a                                      )
344 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
345 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
346 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
347
348 #define unpackWARN1(x)          ((x)        & 0xFF)
349 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
350 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
351 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
352
353 #define ckDEAD(x)                                                       \
354            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
355             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
356               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
357               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
358               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
359               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
360
361 /* end of file warnings.h */
362 /* ex: set ro: */
363 EOM
364
365 safer_close $warn;
366 rename_if_different("warnings.h-new", "warnings.h");
367
368 while (<DATA>) {
369     last if /^KEYWORDS$/ ;
370     print $pm $_ ;
371 }
372
373 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
374
375 $last_ver = 0;
376 print $pm "our %Offsets = (\n" ;
377 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
378     my ($name, $version) = @{ $ValueToName{$k} };
379     $name = lc $name;
380     $k *= 2 ;
381     if ( $last_ver != $version ) {
382         print $pm "\n";
383         print $pm tab(4, "    # Warnings Categories added in Perl $version");
384         print $pm "\n\n";
385     }
386     print $pm tab(4, "    '$name'"), "=> $k,\n" ;
387     $last_ver = $version;
388 }
389
390 print $pm "  );\n\n" ;
391
392 print $pm "our %Bits = (\n" ;
393 foreach $k (sort keys  %list) {
394
395     my $v = $list{$k} ;
396     my @list = sort { $a <=> $b } @$v ;
397
398     print $pm tab(4, "    '$k'"), '=> "',
399                 # mkHex($warn_size, @list),
400                 mkHex($warn_size, map $_ * 2 , @list),
401                 '", # [', mkRange(@list), "]\n" ;
402 }
403
404 print $pm "  );\n\n" ;
405
406 print $pm "our %DeadBits = (\n" ;
407 foreach $k (sort keys  %list) {
408
409     my $v = $list{$k} ;
410     my @list = sort { $a <=> $b } @$v ;
411
412     print $pm tab(4, "    '$k'"), '=> "',
413                 # mkHex($warn_size, @list),
414                 mkHex($warn_size, map $_ * 2 + 1 , @list),
415                 '", # [', mkRange(@list), "]\n" ;
416 }
417
418 print $pm "  );\n\n" ;
419 print $pm '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
420 print $pm '$LAST_BIT = ' . "$index ;\n" ;
421 print $pm '$BYTES    = ' . "$warn_size ;\n" ;
422 while (<DATA>) {
423     print $pm $_ ;
424 }
425
426 print $pm "# ex: set ro:\n";
427 safer_close $pm;
428 rename_if_different("lib/warnings.pm-new", "lib/warnings.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;