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