This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: perl v5.8.0 17303 on VMS_VAX V7.2
[perl5.git] / warnings.pl
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
0ca4541c
NIS
3
4$VERSION = '1.00';
b75c8c73 5
73f0cc2d
GS
6BEGIN {
7 push @INC, './lib';
8}
599cee73
PM
9use strict ;
10
11sub DEFAULT_ON () { 1 }
12sub DEFAULT_OFF () { 2 }
13
14my $tree = {
d3a7d8c7 15
0d658bf5
PM
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 'y2k' => [ 5.008, DEFAULT_OFF],
54 'untie' => [ 5.008, DEFAULT_OFF],
55 'substr' => [ 5.008, DEFAULT_OFF],
56 'taint' => [ 5.008, DEFAULT_OFF],
57 'signal' => [ 5.008, DEFAULT_OFF],
58 'closure' => [ 5.008, DEFAULT_OFF],
59 'overflow' => [ 5.008, DEFAULT_OFF],
60 'portable' => [ 5.008, DEFAULT_OFF],
61 'utf8' => [ 5.008, DEFAULT_OFF],
62 'exiting' => [ 5.008, DEFAULT_OFF],
63 'pack' => [ 5.008, DEFAULT_OFF],
64 'unpack' => [ 5.008, DEFAULT_OFF],
38875929 65 'threads' => [ 5.008, DEFAULT_OFF],
0d658bf5
PM
66 #'default' => [ 5.008, DEFAULT_ON ],
67 }],
d3a7d8c7 68} ;
599cee73 69
599cee73
PM
70###########################################################################
71sub tab {
72 my($l, $t) = @_;
73 $t .= "\t" x ($l - (length($t) + 1) / 8);
74 $t;
75}
76
77###########################################################################
78
79my %list ;
80my %Value ;
0d658bf5
PM
81my %ValueToName ;
82my %NameToValue ;
d3a7d8c7 83my $index ;
599cee73 84
0d658bf5
PM
85my %v_list = () ;
86
87sub 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
109sub 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
599cee73
PM
124sub walk
125{
126 my $tre = shift ;
127 my @list = () ;
128 my ($k, $v) ;
129
95dfd3ab
GS
130 foreach $k (sort keys %$tre) {
131 $v = $tre->{$k};
599cee73 132 die "duplicate key $k\n" if defined $list{$k} ;
0d658bf5
PM
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
599cee73
PM
144 push @list, @{ $list{$k} } ;
145 }
146
147 return @list ;
599cee73
PM
148}
149
150###########################################################################
151
152sub mkRange
153{
154 my @a = @_ ;
155 my @out = @a ;
156 my $i ;
157
158
159 for ($i = 1 ; $i < @a; ++ $i) {
0ca4541c 160 $out[$i] = ".."
599cee73
PM
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###########################################################################
e476b1b5
GS
171sub printTree
172{
173 my $tre = shift ;
174 my $prefix = shift ;
e476b1b5
GS
175 my ($k, $v) ;
176
177 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
0d658bf5 178 my @keys = sort keys %$tre ;
e476b1b5 179
0d658bf5 180 while ($k = shift @keys) {
e476b1b5 181 $v = $tre->{$k};
0d658bf5
PM
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)
0ca4541c 198 {
0d658bf5
PM
199 my $bar = @keys ? "|" : " ";
200 print " -" . "-" x ($max - length $k ) . "+\n" ;
201 printTree ($rest, $prefix . $bar . $offset )
e476b1b5
GS
202 }
203 else
204 { print "\n" }
205 }
206
207}
208
209###########################################################################
599cee73 210
317ea90d 211sub mkHexOct
599cee73 212{
317ea90d 213 my ($f, $max, @a) = @_ ;
599cee73
PM
214 my $mask = "\x00" x $max ;
215 my $string = "" ;
216
217 foreach (@a) {
218 vec($mask, $_, 1) = 1 ;
219 }
220
599cee73 221 foreach (unpack("C*", $mask)) {
317ea90d
MS
222 if ($f eq 'x') {
223 $string .= '\x' . sprintf("%2.2x", $_)
224 }
225 else {
226 $string .= '\\' . sprintf("%o", $_)
227 }
599cee73
PM
228 }
229 return $string ;
230}
231
317ea90d
MS
232sub mkHex
233{
234 my($max, @a) = @_;
235 return mkHexOct("x", $max, @a);
236}
237
238sub mkOct
239{
240 my($max, @a) = @_;
241 return mkHexOct("o", $max, @a);
242}
243
599cee73
PM
244###########################################################################
245
e476b1b5
GS
246if (@ARGV && $ARGV[0] eq "tree")
247{
0d658bf5 248 printTree($tree, " ") ;
e476b1b5
GS
249 exit ;
250}
599cee73 251
918426be
NC
252unlink "warnings.h";
253unlink "lib/warnings.pm";
4438c4b7
JH
254open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
255open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
599cee73
PM
256
257print WARN <<'EOM' ;
258/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 259 This file is built by warnings.pl
599cee73
PM
260 Any changes made here will be lost!
261*/
262
263
0453d815
PM
264#define Off(x) ((x) / 8)
265#define Bit(x) (1 << ((x) % 8))
599cee73
PM
266#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
267
0453d815 268
599cee73 269#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 270#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
271#define G_WARN_ALL_ON 2 /* -W flag */
272#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 273#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
274#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
275
d3a7d8c7
GS
276#define pWARN_STD Nullsv
277#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
278#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73 279
d3a7d8c7
GS
280#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
281 (x) == pWARN_NONE)
599cee73
PM
282EOM
283
d3a7d8c7
GS
284my $offset = 0 ;
285
286$index = $offset ;
287#@{ $list{"all"} } = walk ($tree) ;
0d658bf5
PM
288valueWalk ($tree) ;
289my $index = orderValues();
599cee73 290
12bcd1a6
PM
291die <<EOM if $index > 255 ;
292Too many warnings categories -- max is 255
293 rewrite packWARN* & unpackWARN* macros
294EOM
599cee73 295
0d658bf5
PM
296walk ($tree) ;
297
599cee73
PM
298$index *= 2 ;
299my $warn_size = int($index / 8) + ($index % 8 != 0) ;
300
301my $k ;
0d658bf5
PM
302my $last_ver = 0;
303foreach $k (sort { $a <=> $b } keys %ValueToName) {
304 my ($name, $version) = @{ $ValueToName{$k} };
305 print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
306 if $last_ver != $version ;
307 print WARN tab(5, "#define WARN_$name"), "$k\n" ;
308 $last_ver = $version ;
599cee73
PM
309}
310print WARN "\n" ;
311
312print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
313#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
314print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
315print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
317ea90d
MS
316my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
317
318print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
599cee73
PM
319
320print WARN <<'EOM';
321
d5a71f30
GS
322#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
323#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
324#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
325#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
326#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
327
d5a71f30
GS
328#define ckWARN(x) \
329 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
330 (PL_curcop->cop_warnings == pWARN_ALL || \
331 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
332 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
333
334#define ckWARN2(x,y) \
335 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
336 (PL_curcop->cop_warnings == pWARN_ALL || \
337 isWARN_on(PL_curcop->cop_warnings, x) || \
338 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
339 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
340
12bcd1a6
PM
341#define ckWARN3(x,y,z) \
342 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
343 (PL_curcop->cop_warnings == pWARN_ALL || \
344 isWARN_on(PL_curcop->cop_warnings, x) || \
345 isWARN_on(PL_curcop->cop_warnings, y) || \
346 isWARN_on(PL_curcop->cop_warnings, z) ) ) \
347 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
348
349#define ckWARN4(x,y,z,t) \
350 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
351 (PL_curcop->cop_warnings == pWARN_ALL || \
352 isWARN_on(PL_curcop->cop_warnings, x) || \
353 isWARN_on(PL_curcop->cop_warnings, y) || \
354 isWARN_on(PL_curcop->cop_warnings, z) || \
355 isWARN_on(PL_curcop->cop_warnings, t) ) ) \
356 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
357
d5a71f30
GS
358#define ckWARN_d(x) \
359 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
360 (PL_curcop->cop_warnings != pWARN_NONE && \
361 isWARN_on(PL_curcop->cop_warnings, x) ) )
362
363#define ckWARN2_d(x,y) \
364 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
365 (PL_curcop->cop_warnings != pWARN_NONE && \
366 (isWARN_on(PL_curcop->cop_warnings, x) || \
367 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
368
12bcd1a6
PM
369#define ckWARN3_d(x,y,z) \
370 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
371 (PL_curcop->cop_warnings != pWARN_NONE && \
372 (isWARN_on(PL_curcop->cop_warnings, x) || \
373 isWARN_on(PL_curcop->cop_warnings, y) || \
374 isWARN_on(PL_curcop->cop_warnings, z) ) ) )
375
376#define ckWARN4_d(x,y,z,t) \
377 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
378 (PL_curcop->cop_warnings != pWARN_NONE && \
379 (isWARN_on(PL_curcop->cop_warnings, x) || \
380 isWARN_on(PL_curcop->cop_warnings, y) || \
381 isWARN_on(PL_curcop->cop_warnings, z) || \
382 isWARN_on(PL_curcop->cop_warnings, t) ) ) )
383
384#define packWARN(a) (a )
385#define packWARN2(a,b) ((a) | (b)<<8 )
386#define packWARN3(a,b,c) ((a) | (b)<<8 | (c) <<16 )
387#define packWARN4(a,b,c,d) ((a) | (b)<<8 | (c) <<16 | (d) <<24)
388
389#define unpackWARN1(x) ((x) & 0xFF)
390#define unpackWARN2(x) (((x) >>8) & 0xFF)
391#define unpackWARN3(x) (((x) >>16) & 0xFF)
392#define unpackWARN4(x) (((x) >>24) & 0xFF)
393
394#define ckDEAD(x) \
395 ( ! specialWARN(PL_curcop->cop_warnings) && \
396 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
397 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
398 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
399 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
400 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
401
4438c4b7 402/* end of file warnings.h */
599cee73
PM
403
404EOM
405
406close WARN ;
407
408while (<DATA>) {
409 last if /^KEYWORDS$/ ;
410 print PM $_ ;
411}
412
d3a7d8c7
GS
413#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
414
0d658bf5 415$last_ver = 0;
d3a7d8c7 416print PM "%Offsets = (\n" ;
0d658bf5
PM
417foreach my $k (sort { $a <=> $b } keys %ValueToName) {
418 my ($name, $version) = @{ $ValueToName{$k} };
419 $name = lc $name;
d3a7d8c7 420 $k *= 2 ;
0d658bf5
PM
421 if ( $last_ver != $version ) {
422 print PM "\n";
423 print PM tab(4, " # Warnings Categories added in Perl $version");
424 print PM "\n\n";
425 }
426 print PM tab(4, " '$name'"), "=> $k,\n" ;
427 $last_ver = $version;
d3a7d8c7
GS
428}
429
430print PM " );\n\n" ;
431
599cee73
PM
432print PM "%Bits = (\n" ;
433foreach $k (sort keys %list) {
434
435 my $v = $list{$k} ;
436 my @list = sort { $a <=> $b } @$v ;
437
0ca4541c
NIS
438 print PM tab(4, " '$k'"), '=> "',
439 # mkHex($warn_size, @list),
440 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
441 '", # [', mkRange(@list), "]\n" ;
442}
443
444print PM " );\n\n" ;
445
446print PM "%DeadBits = (\n" ;
447foreach $k (sort keys %list) {
448
449 my $v = $list{$k} ;
450 my @list = sort { $a <=> $b } @$v ;
451
0ca4541c
NIS
452 print PM tab(4, " '$k'"), '=> "',
453 # mkHex($warn_size, @list),
454 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
455 '", # [', mkRange(@list), "]\n" ;
456}
457
458print PM " );\n\n" ;
d3a7d8c7
GS
459print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
460print PM '$LAST_BIT = ' . "$index ;\n" ;
461print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73
PM
462while (<DATA>) {
463 print PM $_ ;
464}
465
466close PM ;
467
468__END__
469
38875929 470# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 471# This file was created by warnings.pl
599cee73
PM
472# Any changes made here will be lost.
473#
474
4438c4b7 475package warnings;
599cee73 476
b75c8c73
MS
477our $VERSION = '1.00';
478
599cee73
PM
479=head1 NAME
480
4438c4b7 481warnings - Perl pragma to control optional warnings
599cee73
PM
482
483=head1 SYNOPSIS
484
4438c4b7
JH
485 use warnings;
486 no warnings;
599cee73 487
4438c4b7
JH
488 use warnings "all";
489 no warnings "all";
599cee73 490
d3a7d8c7
GS
491 use warnings::register;
492 if (warnings::enabled()) {
493 warnings::warn("some warning");
494 }
495
496 if (warnings::enabled("void")) {
e476b1b5
GS
497 warnings::warn("void", "some warning");
498 }
499
7e6d00f8
PM
500 if (warnings::enabled($object)) {
501 warnings::warn($object, "some warning");
502 }
503
721f911b
PM
504 warnings::warnif("some warning");
505 warnings::warnif("void", "some warning");
506 warnings::warnif($object, "some warning");
7e6d00f8 507
599cee73
PM
508=head1 DESCRIPTION
509
0453d815
PM
510If no import list is supplied, all possible warnings are either enabled
511or disabled.
599cee73 512
0ca4541c 513A number of functions are provided to assist module authors.
e476b1b5
GS
514
515=over 4
516
d3a7d8c7
GS
517=item use warnings::register
518
7e6d00f8
PM
519Creates a new warnings category with the same name as the package where
520the call to the pragma is used.
521
522=item warnings::enabled()
523
524Use the warnings category with the same name as the current package.
525
526Return TRUE if that warnings category is enabled in the calling module.
527Otherwise returns FALSE.
528
529=item warnings::enabled($category)
530
531Return TRUE if the warnings category, C<$category>, is enabled in the
532calling module.
533Otherwise returns FALSE.
534
535=item warnings::enabled($object)
536
537Use the name of the class for the object reference, C<$object>, as the
538warnings category.
539
540Return TRUE if that warnings category is enabled in the first scope
541where the object is used.
542Otherwise returns FALSE.
543
544=item warnings::warn($message)
545
546Print C<$message> to STDERR.
547
548Use the warnings category with the same name as the current package.
549
550If that warnings category has been set to "FATAL" in the calling module
551then die. Otherwise return.
552
553=item warnings::warn($category, $message)
554
555Print C<$message> to STDERR.
556
557If the warnings category, C<$category>, has been set to "FATAL" in the
558calling module then die. Otherwise return.
d3a7d8c7 559
7e6d00f8 560=item warnings::warn($object, $message)
e476b1b5 561
7e6d00f8 562Print C<$message> to STDERR.
e476b1b5 563
7e6d00f8
PM
564Use the name of the class for the object reference, C<$object>, as the
565warnings category.
e476b1b5 566
7e6d00f8
PM
567If that warnings category has been set to "FATAL" in the scope where C<$object>
568is first used then die. Otherwise return.
599cee73 569
e476b1b5 570
7e6d00f8
PM
571=item warnings::warnif($message)
572
573Equivalent to:
574
575 if (warnings::enabled())
576 { warnings::warn($message) }
577
578=item warnings::warnif($category, $message)
579
580Equivalent to:
581
582 if (warnings::enabled($category))
583 { warnings::warn($category, $message) }
584
585=item warnings::warnif($object, $message)
586
587Equivalent to:
588
589 if (warnings::enabled($object))
590 { warnings::warn($object, $message) }
d3a7d8c7 591
e476b1b5
GS
592=back
593
749f83fa 594See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
595
596=cut
597
598use Carp ;
599
600KEYWORDS
601
d3a7d8c7
GS
602$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
603
c3186b65
PM
604sub Croaker
605{
606 delete $Carp::CarpInternal{'warnings'};
607 croak @_ ;
608}
609
599cee73
PM
610sub bits {
611 my $mask ;
612 my $catmask ;
613 my $fatal = 0 ;
614 foreach my $word (@_) {
327afb7f
GS
615 if ($word eq 'FATAL') {
616 $fatal = 1;
617 }
d3a7d8c7
GS
618 elsif ($catmask = $Bits{$word}) {
619 $mask |= $catmask ;
620 $mask |= $DeadBits{$word} if $fatal ;
599cee73 621 }
d3a7d8c7 622 else
c3186b65 623 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
624 }
625
626 return $mask ;
627}
628
629sub import {
630 shift;
f1f33818
PM
631 my $mask = ${^WARNING_BITS} ;
632 if (vec($mask, $Offsets{'all'}, 1)) {
633 $mask |= $Bits{'all'} ;
634 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
635 }
636 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
599cee73
PM
637}
638
639sub unimport {
640 shift;
d3a7d8c7
GS
641 my $mask = ${^WARNING_BITS} ;
642 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 643 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
644 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
645 }
08540116 646 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
599cee73
PM
647}
648
7e6d00f8 649sub __chk
599cee73 650{
d3a7d8c7
GS
651 my $category ;
652 my $offset ;
7e6d00f8 653 my $isobj = 0 ;
d3a7d8c7
GS
654
655 if (@_) {
656 # check the category supplied.
657 $category = shift ;
7e6d00f8 658 if (ref $category) {
c3186b65 659 Croaker ("not an object")
3d1a39c8 660 if $category !~ /^([^=]+)=/ ;
7e6d00f8
PM
661 $category = $1 ;
662 $isobj = 1 ;
663 }
d3a7d8c7 664 $offset = $Offsets{$category};
c3186b65 665 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
666 unless defined $offset;
667 }
668 else {
0ca4541c 669 $category = (caller(1))[0] ;
d3a7d8c7 670 $offset = $Offsets{$category};
c3186b65 671 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
672 unless defined $offset ;
673 }
674
0ca4541c 675 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
676 my $i = 2 ;
677 my $pkg ;
678
679 if ($isobj) {
680 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
681 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
682 }
683 $i -= 2 ;
684 }
685 else {
686 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
687 last if $pkg ne $this_pkg ;
688 }
0ca4541c 689 $i = 2
7e6d00f8
PM
690 if !$pkg || $pkg eq $this_pkg ;
691 }
692
0ca4541c 693 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
694 return ($callers_bitmask, $offset, $i) ;
695}
696
697sub enabled
698{
c3186b65 699 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
700 unless @_ == 1 || @_ == 0 ;
701
702 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
703
704 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
705 return vec($callers_bitmask, $offset, 1) ||
706 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
707}
708
d3a7d8c7 709
e476b1b5
GS
710sub warn
711{
c3186b65 712 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 713 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 714
7e6d00f8
PM
715 my $message = pop ;
716 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
0ca4541c 717 croak($message)
d3a7d8c7
GS
718 if vec($callers_bitmask, $offset+1, 1) ||
719 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
720 carp($message) ;
721}
722
7e6d00f8
PM
723sub warnif
724{
c3186b65 725 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
726 unless @_ == 2 || @_ == 1 ;
727
728 my $message = pop ;
729 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 730
0ca4541c 731 return
7e6d00f8
PM
732 unless defined $callers_bitmask &&
733 (vec($callers_bitmask, $offset, 1) ||
734 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
735
0ca4541c 736 croak($message)
7e6d00f8
PM
737 if vec($callers_bitmask, $offset+1, 1) ||
738 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
739
740 carp($message) ;
741}
0d658bf5 742
599cee73 7431;