Make also the -CAL conditional on locale.
[p5sagit/p5-mst-13.2.git] / warnings.pl
CommitLineData
599cee73 1#!/usr/bin/perl
2
0ca4541c 3
4$VERSION = '1.00';
b75c8c73 5
73f0cc2d 6BEGIN {
7 push @INC, './lib';
8}
599cee73 9use strict ;
10
11sub DEFAULT_ON () { 1 }
12sub DEFAULT_OFF () { 2 }
13
14my $tree = {
d3a7d8c7 15
0d658bf5 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 66 #'default' => [ 5.008, DEFAULT_ON ],
67 }],
d3a7d8c7 68} ;
599cee73 69
599cee73 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 81my %ValueToName ;
82my %NameToValue ;
d3a7d8c7 83my $index ;
599cee73 84
0d658bf5 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 124sub walk
125{
126 my $tre = shift ;
127 my @list = () ;
128 my ($k, $v) ;
129
95dfd3ab 130 foreach $k (sort keys %$tre) {
131 $v = $tre->{$k};
599cee73 132 die "duplicate key $k\n" if defined $list{$k} ;
0d658bf5 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 144 push @list, @{ $list{$k} } ;
145 }
146
147 return @list ;
599cee73 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 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 171sub printTree
172{
173 my $tre = shift ;
174 my $prefix = shift ;
e476b1b5 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 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 199 my $bar = @keys ? "|" : " ";
200 print " -" . "-" x ($max - length $k ) . "+\n" ;
201 printTree ($rest, $prefix . $bar . $offset )
e476b1b5 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 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 222 if ($f eq 'x') {
223 $string .= '\x' . sprintf("%2.2x", $_)
224 }
225 else {
226 $string .= '\\' . sprintf("%o", $_)
227 }
599cee73 228 }
229 return $string ;
230}
231
317ea90d 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 244###########################################################################
245
e476b1b5 246if (@ARGV && $ARGV[0] eq "tree")
247{
0d658bf5 248 printTree($tree, " ") ;
e476b1b5 249 exit ;
250}
599cee73 251
918426be 252unlink "warnings.h";
253unlink "lib/warnings.pm";
4438c4b7 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 256
257print WARN <<'EOM' ;
258/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 259 This file is built by warnings.pl
599cee73 260 Any changes made here will be lost!
261*/
262
263
0453d815 264#define Off(x) ((x) / 8)
265#define Bit(x) (1 << ((x) % 8))
599cee73 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 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 274#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
275
d3a7d8c7 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 280#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
281 (x) == pWARN_NONE)
599cee73 282EOM
283
d3a7d8c7 284my $offset = 0 ;
285
286$index = $offset ;
287#@{ $list{"all"} } = walk ($tree) ;
0d658bf5 288valueWalk ($tree) ;
289my $index = orderValues();
599cee73 290
12bcd1a6 291die <<EOM if $index > 255 ;
292Too many warnings categories -- max is 255
293 rewrite packWARN* & unpackWARN* macros
294EOM
599cee73 295
0d658bf5 296walk ($tree) ;
297
599cee73 298$index *= 2 ;
299my $warn_size = int($index / 8) + ($index % 8 != 0) ;
300
301my $k ;
0d658bf5 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 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 316my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
317
318print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
599cee73 319
320print WARN <<'EOM';
321
d5a71f30 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 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 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 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 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 403
404EOM
405
406close WARN ;
407
408while (<DATA>) {
409 last if /^KEYWORDS$/ ;
410 print PM $_ ;
411}
412
d3a7d8c7 413#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
414
0d658bf5 415$last_ver = 0;
d3a7d8c7 416print PM "%Offsets = (\n" ;
0d658bf5 417foreach my $k (sort { $a <=> $b } keys %ValueToName) {
418 my ($name, $version) = @{ $ValueToName{$k} };
419 $name = lc $name;
d3a7d8c7 420 $k *= 2 ;
0d658bf5 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 428}
429
430print PM " );\n\n" ;
431
599cee73 432print PM "%Bits = (\n" ;
433foreach $k (sort keys %list) {
434
435 my $v = $list{$k} ;
436 my @list = sort { $a <=> $b } @$v ;
437
0ca4541c 438 print PM tab(4, " '$k'"), '=> "',
439 # mkHex($warn_size, @list),
440 mkHex($warn_size, map $_ * 2 , @list),
599cee73 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 452 print PM tab(4, " '$k'"), '=> "',
453 # mkHex($warn_size, @list),
454 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73 455 '", # [', mkRange(@list), "]\n" ;
456}
457
458print PM " );\n\n" ;
d3a7d8c7 459print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
460print PM '$LAST_BIT = ' . "$index ;\n" ;
461print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73 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 472# Any changes made here will be lost.
473#
474
4438c4b7 475package warnings;
599cee73 476
b75c8c73 477our $VERSION = '1.00';
478
599cee73 479=head1 NAME
480
4438c4b7 481warnings - Perl pragma to control optional warnings
599cee73 482
483=head1 SYNOPSIS
484
4438c4b7 485 use warnings;
486 no warnings;
599cee73 487
4438c4b7 488 use warnings "all";
489 no warnings "all";
599cee73 490
d3a7d8c7 491 use warnings::register;
492 if (warnings::enabled()) {
493 warnings::warn("some warning");
494 }
495
496 if (warnings::enabled("void")) {
e476b1b5 497 warnings::warn("void", "some warning");
498 }
499
7e6d00f8 500 if (warnings::enabled($object)) {
501 warnings::warn($object, "some warning");
502 }
503
721f911b 504 warnings::warnif("some warning");
505 warnings::warnif("void", "some warning");
506 warnings::warnif($object, "some warning");
7e6d00f8 507
599cee73 508=head1 DESCRIPTION
509
0453d815 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 514
515=over 4
516
d3a7d8c7 517=item use warnings::register
518
7e6d00f8 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 564Use the name of the class for the object reference, C<$object>, as the
565warnings category.
e476b1b5 566
7e6d00f8 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 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 592=back
593
749f83fa 594See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73 595
596=cut
597
598use Carp ;
599
600KEYWORDS
601
d3a7d8c7 602$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
603
c3186b65 604sub Croaker
605{
606 delete $Carp::CarpInternal{'warnings'};
f5e3445d 607 croak(@_);
c3186b65 608}
609
6e9af7e4 610sub bits
611{
612 # called from B::Deparse.pm
613
614 push @_, 'all' unless @_;
615
616 my $mask;
599cee73 617 my $catmask ;
618 my $fatal = 0 ;
6e9af7e4 619 my $no_fatal = 0 ;
620
621 foreach my $word ( @_ ) {
622 if ($word eq 'FATAL') {
327afb7f 623 $fatal = 1;
6e9af7e4 624 $no_fatal = 0;
625 }
626 elsif ($word eq 'NONFATAL') {
627 $fatal = 0;
628 $no_fatal = 1;
327afb7f 629 }
d3a7d8c7 630 elsif ($catmask = $Bits{$word}) {
631 $mask |= $catmask ;
632 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 633 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 634 }
d3a7d8c7 635 else
c3186b65 636 { Croaker("Unknown warnings category '$word'")}
599cee73 637 }
638
639 return $mask ;
640}
641
6e9af7e4 642sub import
643{
599cee73 644 shift;
6e9af7e4 645
646 my $catmask ;
647 my $fatal = 0 ;
648 my $no_fatal = 0 ;
649
f1f33818 650 my $mask = ${^WARNING_BITS} ;
6e9af7e4 651
f1f33818 652 if (vec($mask, $Offsets{'all'}, 1)) {
653 $mask |= $Bits{'all'} ;
654 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
655 }
6e9af7e4 656
657 push @_, 'all' unless @_;
658
659 foreach my $word ( @_ ) {
660 if ($word eq 'FATAL') {
661 $fatal = 1;
662 $no_fatal = 0;
663 }
664 elsif ($word eq 'NONFATAL') {
665 $fatal = 0;
666 $no_fatal = 1;
667 }
668 elsif ($catmask = $Bits{$word}) {
669 $mask |= $catmask ;
670 $mask |= $DeadBits{$word} if $fatal ;
671 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
672 }
673 else
674 { Croaker("Unknown warnings category '$word'")}
675 }
676
677 ${^WARNING_BITS} = $mask ;
599cee73 678}
679
6e9af7e4 680sub unimport
681{
599cee73 682 shift;
6e9af7e4 683
684 my $catmask ;
d3a7d8c7 685 my $mask = ${^WARNING_BITS} ;
6e9af7e4 686
d3a7d8c7 687 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 688 $mask |= $Bits{'all'} ;
d3a7d8c7 689 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
690 }
6e9af7e4 691
692 push @_, 'all' unless @_;
693
694 foreach my $word ( @_ ) {
695 if ($word eq 'FATAL') {
696 next;
697 }
698 elsif ($catmask = $Bits{$word}) {
699 $mask &= ~($catmask | $DeadBits{$word} | $All);
700 }
701 else
702 { Croaker("Unknown warnings category '$word'")}
703 }
704
705 ${^WARNING_BITS} = $mask ;
599cee73 706}
707
7e6d00f8 708sub __chk
599cee73 709{
d3a7d8c7 710 my $category ;
711 my $offset ;
7e6d00f8 712 my $isobj = 0 ;
d3a7d8c7 713
714 if (@_) {
715 # check the category supplied.
716 $category = shift ;
7e6d00f8 717 if (ref $category) {
c3186b65 718 Croaker ("not an object")
3d1a39c8 719 if $category !~ /^([^=]+)=/ ;
7e6d00f8 720 $category = $1 ;
721 $isobj = 1 ;
722 }
d3a7d8c7 723 $offset = $Offsets{$category};
c3186b65 724 Croaker("Unknown warnings category '$category'")
d3a7d8c7 725 unless defined $offset;
726 }
727 else {
0ca4541c 728 $category = (caller(1))[0] ;
d3a7d8c7 729 $offset = $Offsets{$category};
c3186b65 730 Croaker("package '$category' not registered for warnings")
d3a7d8c7 731 unless defined $offset ;
732 }
733
0ca4541c 734 my $this_pkg = (caller(1))[0] ;
7e6d00f8 735 my $i = 2 ;
736 my $pkg ;
737
738 if ($isobj) {
739 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
740 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
741 }
742 $i -= 2 ;
743 }
744 else {
745 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
746 last if $pkg ne $this_pkg ;
747 }
0ca4541c 748 $i = 2
7e6d00f8 749 if !$pkg || $pkg eq $this_pkg ;
750 }
751
0ca4541c 752 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8 753 return ($callers_bitmask, $offset, $i) ;
754}
755
756sub enabled
757{
c3186b65 758 Croaker("Usage: warnings::enabled([category])")
7e6d00f8 759 unless @_ == 1 || @_ == 0 ;
760
761 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
762
763 return 0 unless defined $callers_bitmask ;
d3a7d8c7 764 return vec($callers_bitmask, $offset, 1) ||
765 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73 766}
767
d3a7d8c7 768
e476b1b5 769sub warn
770{
c3186b65 771 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 772 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 773
7e6d00f8 774 my $message = pop ;
775 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
0ca4541c 776 croak($message)
d3a7d8c7 777 if vec($callers_bitmask, $offset+1, 1) ||
778 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5 779 carp($message) ;
780}
781
7e6d00f8 782sub warnif
783{
c3186b65 784 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8 785 unless @_ == 2 || @_ == 1 ;
786
787 my $message = pop ;
788 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 789
0ca4541c 790 return
7e6d00f8 791 unless defined $callers_bitmask &&
792 (vec($callers_bitmask, $offset, 1) ||
793 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
794
0ca4541c 795 croak($message)
7e6d00f8 796 if vec($callers_bitmask, $offset+1, 1) ||
797 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
798
799 carp($message) ;
800}
0d658bf5 801
599cee73 8021;