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