RE: Combining UTF-16 output with :crlf is awkward
[perl.git] / warnings.pl
1 #!/usr/bin/perl
2
3 $VERSION = '1.02_02';
4
5 BEGIN {
6   push @INC, './lib';
7 }
8 use strict ;
9
10 sub DEFAULT_ON  () { 1 }
11 sub DEFAULT_OFF () { 2 }
12
13 my $tree = {
14
15 'all' => [ 5.008, {
16         'io'            => [ 5.008, {   
17                                 'pipe'          => [ 5.008, DEFAULT_OFF],
18                                 'unopened'      => [ 5.008, DEFAULT_OFF],
19                                 'closed'        => [ 5.008, DEFAULT_OFF],
20                                 'newline'       => [ 5.008, DEFAULT_OFF],
21                                 'exec'          => [ 5.008, DEFAULT_OFF],
22                                 'layer'         => [ 5.008, DEFAULT_OFF],
23                            }],
24         'syntax'        => [ 5.008, {   
25                                 'ambiguous'     => [ 5.008, DEFAULT_OFF],
26                                 'semicolon'     => [ 5.008, DEFAULT_OFF],
27                                 'precedence'    => [ 5.008, DEFAULT_OFF],
28                                 'bareword'      => [ 5.008, DEFAULT_OFF],
29                                 'reserved'      => [ 5.008, DEFAULT_OFF],
30                                 'digit'         => [ 5.008, DEFAULT_OFF],
31                                 'parenthesis'   => [ 5.008, DEFAULT_OFF],
32                                 'printf'        => [ 5.008, DEFAULT_OFF],
33                                 'prototype'     => [ 5.008, DEFAULT_OFF],
34                                 'qw'            => [ 5.008, DEFAULT_OFF],
35                            }],
36         'severe'        => [ 5.008, {   
37                                 'inplace'       => [ 5.008, DEFAULT_ON],
38                                 'internal'      => [ 5.008, DEFAULT_ON],
39                                 'debugging'     => [ 5.008, DEFAULT_ON],
40                                 'malloc'        => [ 5.008, DEFAULT_ON],
41                            }],
42         'deprecated'    => [ 5.008, DEFAULT_OFF],
43         'void'          => [ 5.008, DEFAULT_OFF],
44         'recursion'     => [ 5.008, DEFAULT_OFF],
45         'redefine'      => [ 5.008, DEFAULT_OFF],
46         'numeric'       => [ 5.008, DEFAULT_OFF],
47         'uninitialized' => [ 5.008, DEFAULT_OFF],
48         'once'          => [ 5.008, DEFAULT_OFF],
49         'misc'          => [ 5.008, DEFAULT_OFF],
50         'regexp'        => [ 5.008, DEFAULT_OFF],
51         'glob'          => [ 5.008, DEFAULT_OFF],
52         'untie'         => [ 5.008, DEFAULT_OFF],
53         'substr'        => [ 5.008, DEFAULT_OFF],
54         'taint'         => [ 5.008, DEFAULT_OFF],
55         'signal'        => [ 5.008, DEFAULT_OFF],
56         'closure'       => [ 5.008, DEFAULT_OFF],
57         'overflow'      => [ 5.008, DEFAULT_OFF],
58         'portable'      => [ 5.008, DEFAULT_OFF],
59         'utf8'          => [ 5.008, DEFAULT_OFF],
60         'exiting'       => [ 5.008, DEFAULT_OFF],
61         'pack'          => [ 5.008, DEFAULT_OFF],
62         'unpack'        => [ 5.008, DEFAULT_OFF],
63         'threads'       => [ 5.008, DEFAULT_OFF],
64         'assertions'    => [ 5.009, DEFAULT_OFF],
65
66          #'default'     => [ 5.008, DEFAULT_ON ],
67         }],
68 } ;
69
70 ###########################################################################
71 sub tab {
72     my($l, $t) = @_;
73     $t .= "\t" x ($l - (length($t) + 1) / 8);
74     $t;
75 }
76
77 ###########################################################################
78
79 my %list ;
80 my %Value ;
81 my %ValueToName ;
82 my %NameToValue ;
83 my $index ;
84
85 my %v_list = () ;
86
87 sub valueWalk
88 {
89     my $tre = shift ;
90     my @list = () ;
91     my ($k, $v) ;
92
93     foreach $k (sort keys %$tre) {
94         $v = $tre->{$k};
95         die "duplicate key $k\n" if defined $list{$k} ;
96         die "Value associated with key '$k' is not an ARRAY reference"
97             if !ref $v || ref $v ne 'ARRAY' ;
98
99         my ($ver, $rest) = @{ $v } ;
100         push @{ $v_list{$ver} }, $k;
101         
102         if (ref $rest)
103           { valueWalk ($rest) }
104
105     }
106
107 }
108
109 sub orderValues
110 {
111     my $index = 0;
112     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
113         foreach my $name (@{ $v_list{$ver} } ) {
114             $ValueToName{ $index } = [ uc $name, $ver ] ;
115             $NameToValue{ uc $name } = $index ++ ;
116         }
117     }
118
119     return $index ;
120 }
121
122 ###########################################################################
123
124 sub walk
125 {
126     my $tre = shift ;
127     my @list = () ;
128     my ($k, $v) ;
129
130     foreach $k (sort keys %$tre) {
131         $v = $tre->{$k};
132         die "duplicate key $k\n" if defined $list{$k} ;
133         #$Value{$index} = uc $k ;
134         die "Can't find key '$k'"
135             if ! defined $NameToValue{uc $k} ;
136         push @{ $list{$k} }, $NameToValue{uc $k} ;
137         die "Value associated with key '$k' is not an ARRAY reference"
138             if !ref $v || ref $v ne 'ARRAY' ;
139         
140         my ($ver, $rest) = @{ $v } ;
141         if (ref $rest)
142           { push (@{ $list{$k} }, walk ($rest)) }
143
144         push @list, @{ $list{$k} } ;
145     }
146
147    return @list ;
148 }
149
150 ###########################################################################
151
152 sub mkRange
153 {
154     my @a = @_ ;
155     my @out = @a ;
156     my $i ;
157
158
159     for ($i = 1 ; $i < @a; ++ $i) {
160         $out[$i] = ".."
161           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
162     }
163
164     my $out = join(",",@out);
165
166     $out =~ s/,(\.\.,)+/../g ;
167     return $out;
168 }
169
170 ###########################################################################
171 sub printTree
172 {
173     my $tre = shift ;
174     my $prefix = shift ;
175     my ($k, $v) ;
176
177     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
178     my @keys = sort keys %$tre ;
179
180     while ($k = shift @keys) {
181         $v = $tre->{$k};
182         die "Value associated with key '$k' is not an ARRAY reference"
183             if !ref $v || ref $v ne 'ARRAY' ;
184         
185         my $offset ;
186         if ($tre ne $tree) {
187             print $prefix . "|\n" ;
188             print $prefix . "+- $k" ;
189             $offset = ' ' x ($max + 4) ;
190         }
191         else {
192             print $prefix . "$k" ;
193             $offset = ' ' x ($max + 1) ;
194         }
195
196         my ($ver, $rest) = @{ $v } ;
197         if (ref $rest)
198         {
199             my $bar = @keys ? "|" : " ";
200             print " -" . "-" x ($max - length $k ) . "+\n" ;
201             printTree ($rest, $prefix . $bar . $offset )
202         }
203         else
204           { print "\n" }
205     }
206
207 }
208
209 ###########################################################################
210
211 sub mkHexOct
212 {
213     my ($f, $max, @a) = @_ ;
214     my $mask = "\x00" x $max ;
215     my $string = "" ;
216
217     foreach (@a) {
218         vec($mask, $_, 1) = 1 ;
219     }
220
221     foreach (unpack("C*", $mask)) {
222         if ($f eq 'x') {
223             $string .= '\x' . sprintf("%2.2x", $_)
224         }
225         else {
226             $string .= '\\' . sprintf("%o", $_)
227         }
228     }
229     return $string ;
230 }
231
232 sub mkHex
233 {
234     my($max, @a) = @_;
235     return mkHexOct("x", $max, @a);
236 }
237
238 sub mkOct
239 {
240     my($max, @a) = @_;
241     return mkHexOct("o", $max, @a);
242 }
243
244 ###########################################################################
245
246 if (@ARGV && $ARGV[0] eq "tree")
247 {
248     printTree($tree, "    ") ;
249     exit ;
250 }
251
252 unlink "warnings.h";
253 unlink "lib/warnings.pm";
254 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
255 binmode WARN;
256 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
257 binmode PM;
258
259 print WARN <<'EOM' ;
260 /* -*- buffer-read-only: t -*-
261    !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
262    This file is built by warnings.pl
263    Any changes made here will be lost!
264 */
265
266
267 #define Off(x)                  ((x) / 8)
268 #define Bit(x)                  (1 << ((x) % 8))
269 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
270
271
272 #define G_WARN_OFF              0       /* $^W == 0 */
273 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
274 #define G_WARN_ALL_ON           2       /* -W flag */
275 #define G_WARN_ALL_OFF          4       /* -X flag */
276 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
277 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
278
279 #define pWARN_STD               NULL
280 #define pWARN_ALL               (((STRLEN*)0)+1)    /* use warnings 'all' */
281 #define pWARN_NONE              (((STRLEN*)0)+2)    /* no  warnings 'all' */
282
283 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
284                                  (x) == pWARN_NONE)
285
286 /* if PL_warnhook is set to this value, then warnings die */
287 #define PERL_WARNHOOK_FATAL     (((SV*)0) + 1)
288 EOM
289
290 my $offset = 0 ;
291
292 $index = $offset ;
293 #@{ $list{"all"} } = walk ($tree) ;
294 valueWalk ($tree) ;
295 my $index = orderValues();
296
297 die <<EOM if $index > 255 ;
298 Too many warnings categories -- max is 255
299     rewrite packWARN* & unpackWARN* macros 
300 EOM
301
302 walk ($tree) ;
303
304 $index *= 2 ;
305 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
306
307 my $k ;
308 my $last_ver = 0;
309 foreach $k (sort { $a <=> $b } keys %ValueToName) {
310     my ($name, $version) = @{ $ValueToName{$k} };
311     print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
312         if $last_ver != $version ;
313     print WARN tab(5, "#define WARN_$name"), "$k\n" ;
314     $last_ver = $version ;
315 }
316 print WARN "\n" ;
317
318 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
319 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
320 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
321 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
322 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
323
324 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
325
326 print WARN <<'EOM';
327
328 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
329 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
330 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
331 #define isWARN_on(c,x)  (IsSet((U8 *)(c + 1), 2*(x)))
332 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
333
334 #define DUP_WARNINGS(p)         \
335     (STRLEN*)(specialWARN(p) ? (p)      \
336     : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char))
337
338 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
339 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
340 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
341 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
342
343 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
344 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
345 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
346 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
347
348 #define packWARN(a)             (a                                      )
349 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
350 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
351 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
352
353 #define unpackWARN1(x)          ((x)        & 0xFF)
354 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
355 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
356 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
357
358 #define ckDEAD(x)                                                       \
359            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
360             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
361               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
362               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
363               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
364               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
365
366 /* end of file warnings.h */
367 /* ex: set ro: */
368 EOM
369
370 close WARN ;
371
372 while (<DATA>) {
373     last if /^KEYWORDS$/ ;
374     print PM $_ ;
375 }
376
377 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
378
379 $last_ver = 0;
380 print PM "our %Offsets = (\n" ;
381 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
382     my ($name, $version) = @{ $ValueToName{$k} };
383     $name = lc $name;
384     $k *= 2 ;
385     if ( $last_ver != $version ) {
386         print PM "\n";
387         print PM tab(4, "    # Warnings Categories added in Perl $version");
388         print PM "\n\n";
389     }
390     print PM tab(4, "    '$name'"), "=> $k,\n" ;
391     $last_ver = $version;
392 }
393
394 print PM "  );\n\n" ;
395
396 print PM "our %Bits = (\n" ;
397 foreach $k (sort keys  %list) {
398
399     my $v = $list{$k} ;
400     my @list = sort { $a <=> $b } @$v ;
401
402     print PM tab(4, "    '$k'"), '=> "',
403                 # mkHex($warn_size, @list),
404                 mkHex($warn_size, map $_ * 2 , @list),
405                 '", # [', mkRange(@list), "]\n" ;
406 }
407
408 print PM "  );\n\n" ;
409
410 print PM "our %DeadBits = (\n" ;
411 foreach $k (sort keys  %list) {
412
413     my $v = $list{$k} ;
414     my @list = sort { $a <=> $b } @$v ;
415
416     print PM tab(4, "    '$k'"), '=> "',
417                 # mkHex($warn_size, @list),
418                 mkHex($warn_size, map $_ * 2 + 1 , @list),
419                 '", # [', mkRange(@list), "]\n" ;
420 }
421
422 print PM "  );\n\n" ;
423 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
424 print PM '$LAST_BIT = ' . "$index ;\n" ;
425 print PM '$BYTES    = ' . "$warn_size ;\n" ;
426 while (<DATA>) {
427     print PM $_ ;
428 }
429
430 print PM "# ex: set ro:\n";
431 close PM ;
432
433 __END__
434 # -*- buffer-read-only: t -*-
435 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
436 # This file was created by warnings.pl
437 # Any changes made here will be lost.
438 #
439
440 package warnings;
441
442 our $VERSION = '1.05';
443
444 =head1 NAME
445
446 warnings - Perl pragma to control optional warnings
447
448 =head1 SYNOPSIS
449
450     use warnings;
451     no warnings;
452
453     use warnings "all";
454     no warnings "all";
455
456     use warnings::register;
457     if (warnings::enabled()) {
458         warnings::warn("some warning");
459     }
460
461     if (warnings::enabled("void")) {
462         warnings::warn("void", "some warning");
463     }
464
465     if (warnings::enabled($object)) {
466         warnings::warn($object, "some warning");
467     }
468
469     warnings::warnif("some warning");
470     warnings::warnif("void", "some warning");
471     warnings::warnif($object, "some warning");
472
473 =head1 DESCRIPTION
474
475 The C<warnings> pragma is a replacement for the command line flag C<-w>,
476 but the pragma is limited to the enclosing block, while the flag is global.
477 See L<perllexwarn> for more information.
478
479 If no import list is supplied, all possible warnings are either enabled
480 or disabled.
481
482 A number of functions are provided to assist module authors.
483
484 =over 4
485
486 =item use warnings::register
487
488 Creates a new warnings category with the same name as the package where
489 the call to the pragma is used.
490
491 =item warnings::enabled()
492
493 Use the warnings category with the same name as the current package.
494
495 Return TRUE if that warnings category is enabled in the calling module.
496 Otherwise returns FALSE.
497
498 =item warnings::enabled($category)
499
500 Return TRUE if the warnings category, C<$category>, is enabled in the
501 calling module.
502 Otherwise returns FALSE.
503
504 =item warnings::enabled($object)
505
506 Use the name of the class for the object reference, C<$object>, as the
507 warnings category.
508
509 Return TRUE if that warnings category is enabled in the first scope
510 where the object is used.
511 Otherwise returns FALSE.
512
513 =item warnings::warn($message)
514
515 Print C<$message> to STDERR.
516
517 Use the warnings category with the same name as the current package.
518
519 If that warnings category has been set to "FATAL" in the calling module
520 then die. Otherwise return.
521
522 =item warnings::warn($category, $message)
523
524 Print C<$message> to STDERR.
525
526 If the warnings category, C<$category>, has been set to "FATAL" in the
527 calling module then die. Otherwise return.
528
529 =item warnings::warn($object, $message)
530
531 Print C<$message> to STDERR.
532
533 Use the name of the class for the object reference, C<$object>, as the
534 warnings category.
535
536 If that warnings category has been set to "FATAL" in the scope where C<$object>
537 is first used then die. Otherwise return.
538
539
540 =item warnings::warnif($message)
541
542 Equivalent to:
543
544     if (warnings::enabled())
545       { warnings::warn($message) }
546
547 =item warnings::warnif($category, $message)
548
549 Equivalent to:
550
551     if (warnings::enabled($category))
552       { warnings::warn($category, $message) }
553
554 =item warnings::warnif($object, $message)
555
556 Equivalent to:
557
558     if (warnings::enabled($object))
559       { warnings::warn($object, $message) }
560
561 =back
562
563 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
564
565 =cut
566
567 KEYWORDS
568
569 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
570
571 sub Croaker
572 {
573     require Carp::Heavy; # this initializes %CarpInternal
574     local $Carp::CarpInternal{'warnings'};
575     delete $Carp::CarpInternal{'warnings'};
576     Carp::croak(@_);
577 }
578
579 sub bits
580 {
581     # called from B::Deparse.pm
582
583     push @_, 'all' unless @_;
584
585     my $mask;
586     my $catmask ;
587     my $fatal = 0 ;
588     my $no_fatal = 0 ;
589
590     foreach my $word ( @_ ) {
591         if ($word eq 'FATAL') {
592             $fatal = 1;
593             $no_fatal = 0;
594         }
595         elsif ($word eq 'NONFATAL') {
596             $fatal = 0;
597             $no_fatal = 1;
598         }
599         elsif ($catmask = $Bits{$word}) {
600             $mask |= $catmask ;
601             $mask |= $DeadBits{$word} if $fatal ;
602             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
603         }
604         else
605           { Croaker("Unknown warnings category '$word'")}
606     }
607
608     return $mask ;
609 }
610
611 sub import 
612 {
613     shift;
614
615     my $catmask ;
616     my $fatal = 0 ;
617     my $no_fatal = 0 ;
618
619     my $mask = ${^WARNING_BITS} ;
620
621     if (vec($mask, $Offsets{'all'}, 1)) {
622         $mask |= $Bits{'all'} ;
623         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
624     }
625     
626     push @_, 'all' unless @_;
627
628     foreach my $word ( @_ ) {
629         if ($word eq 'FATAL') {
630             $fatal = 1;
631             $no_fatal = 0;
632         }
633         elsif ($word eq 'NONFATAL') {
634             $fatal = 0;
635             $no_fatal = 1;
636         }
637         elsif ($catmask = $Bits{$word}) {
638             $mask |= $catmask ;
639             $mask |= $DeadBits{$word} if $fatal ;
640             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
641         }
642         else
643           { Croaker("Unknown warnings category '$word'")}
644     }
645
646     ${^WARNING_BITS} = $mask ;
647 }
648
649 sub unimport 
650 {
651     shift;
652
653     my $catmask ;
654     my $mask = ${^WARNING_BITS} ;
655
656     if (vec($mask, $Offsets{'all'}, 1)) {
657         $mask |= $Bits{'all'} ;
658         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
659     }
660
661     push @_, 'all' unless @_;
662
663     foreach my $word ( @_ ) {
664         if ($word eq 'FATAL') {
665             next; 
666         }
667         elsif ($catmask = $Bits{$word}) {
668             $mask &= ~($catmask | $DeadBits{$word} | $All);
669         }
670         else
671           { Croaker("Unknown warnings category '$word'")}
672     }
673
674     ${^WARNING_BITS} = $mask ;
675 }
676
677 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
678
679 sub __chk
680 {
681     my $category ;
682     my $offset ;
683     my $isobj = 0 ;
684
685     if (@_) {
686         # check the category supplied.
687         $category = shift ;
688         if (my $type = ref $category) {
689             Croaker("not an object")
690                 if exists $builtin_type{$type};
691             $category = $type;
692             $isobj = 1 ;
693         }
694         $offset = $Offsets{$category};
695         Croaker("Unknown warnings category '$category'")
696             unless defined $offset;
697     }
698     else {
699         $category = (caller(1))[0] ;
700         $offset = $Offsets{$category};
701         Croaker("package '$category' not registered for warnings")
702             unless defined $offset ;
703     }
704
705     my $this_pkg = (caller(1))[0] ;
706     my $i = 2 ;
707     my $pkg ;
708
709     if ($isobj) {
710         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
711             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
712         }
713         $i -= 2 ;
714     }
715     else {
716         $i = _error_loc(); # see where Carp will allocate the error
717     }
718
719     my $callers_bitmask = (caller($i))[9] ;
720     return ($callers_bitmask, $offset, $i) ;
721 }
722
723 sub _error_loc {
724     require Carp::Heavy;
725     goto &Carp::short_error_loc; # don't introduce another stack frame
726 }                                                             
727
728 sub enabled
729 {
730     Croaker("Usage: warnings::enabled([category])")
731         unless @_ == 1 || @_ == 0 ;
732
733     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
734
735     return 0 unless defined $callers_bitmask ;
736     return vec($callers_bitmask, $offset, 1) ||
737            vec($callers_bitmask, $Offsets{'all'}, 1) ;
738 }
739
740
741 sub warn
742 {
743     Croaker("Usage: warnings::warn([category,] 'message')")
744         unless @_ == 2 || @_ == 1 ;
745
746     my $message = pop ;
747     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
748     require Carp;
749     Carp::croak($message)
750         if vec($callers_bitmask, $offset+1, 1) ||
751            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
752     Carp::carp($message) ;
753 }
754
755 sub warnif
756 {
757     Croaker("Usage: warnings::warnif([category,] 'message')")
758         unless @_ == 2 || @_ == 1 ;
759
760     my $message = pop ;
761     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
762
763     return
764         unless defined $callers_bitmask &&
765                 (vec($callers_bitmask, $offset, 1) ||
766                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
767
768     require Carp;
769     Carp::croak($message)
770         if vec($callers_bitmask, $offset+1, 1) ||
771            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
772
773     Carp::carp($message) ;
774 }
775
776 1;