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