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