This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
warn if ++ or -- are unable to change the value because it's beyond
[perl5.git] / warnings.pl
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
98225a64 3$VERSION = '1.02_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],
0d658bf5
PM
52 'untie' => [ 5.008, DEFAULT_OFF],
53 'substr' => [ 5.008, DEFAULT_OFF],
54 'taint' => [ 5.008, DEFAULT_OFF],
55 'signal' => [ 5.008, DEFAULT_OFF],
56 'closure' => [ 5.008, DEFAULT_OFF],
57 'overflow' => [ 5.008, DEFAULT_OFF],
58 'portable' => [ 5.008, DEFAULT_OFF],
59 'utf8' => [ 5.008, DEFAULT_OFF],
60 'exiting' => [ 5.008, DEFAULT_OFF],
61 'pack' => [ 5.008, DEFAULT_OFF],
62 'unpack' => [ 5.008, DEFAULT_OFF],
38875929 63 'threads' => [ 5.008, DEFAULT_OFF],
b88df990 64 'imprecision' => [ 5.011, DEFAULT_OFF],
8fa7688f 65
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 254open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
dfb1454f 255binmode WARN;
4438c4b7 256open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
dfb1454f 257binmode PM;
599cee73
PM
258
259print WARN <<'EOM' ;
37442d52
RGS
260/* -*- buffer-read-only: t -*-
261 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 262 This file is built by warnings.pl
599cee73
PM
263 Any changes made here will be lost!
264*/
265
266
0453d815
PM
267#define Off(x) ((x) / 8)
268#define Bit(x) (1 << ((x) % 8))
599cee73
PM
269#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
270
0453d815 271
599cee73 272#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 273#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
274#define G_WARN_ALL_ON 2 /* -W flag */
275#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 276#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
277#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
278
a0714e2c 279#define pWARN_STD NULL
72dc9ed5
NC
280#define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
281#define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
599cee73 282
d3a7d8c7
GS
283#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
284 (x) == pWARN_NONE)
5f2d9966
DM
285
286/* if PL_warnhook is set to this value, then warnings die */
06dcd5bf 287#define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
599cee73
PM
288EOM
289
d3a7d8c7
GS
290my $offset = 0 ;
291
292$index = $offset ;
293#@{ $list{"all"} } = walk ($tree) ;
0d658bf5
PM
294valueWalk ($tree) ;
295my $index = orderValues();
599cee73 296
12bcd1a6
PM
297die <<EOM if $index > 255 ;
298Too many warnings categories -- max is 255
299 rewrite packWARN* & unpackWARN* macros
300EOM
599cee73 301
0d658bf5
PM
302walk ($tree) ;
303
599cee73
PM
304$index *= 2 ;
305my $warn_size = int($index / 8) + ($index % 8 != 0) ;
306
307my $k ;
0d658bf5
PM
308my $last_ver = 0;
309foreach $k (sort { $a <=> $b } keys %ValueToName) {
310 my ($name, $version) = @{ $ValueToName{$k} };
311 print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
312 if $last_ver != $version ;
313 print WARN tab(5, "#define WARN_$name"), "$k\n" ;
314 $last_ver = $version ;
599cee73
PM
315}
316print WARN "\n" ;
317
318print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
319#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
320print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
321print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
322
323print WARN <<'EOM';
324
d5a71f30
GS
325#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
326#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
327#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
72dc9ed5
NC
328#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
329#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
330
331#define DUP_WARNINGS(p) \
594cd643
NC
332 (specialWARN(p) ? (STRLEN*)(p) \
333 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
334 char))
d5a71f30 335
f54ba1c2
DM
336#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
337#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
338#define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
339#define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
340
341#define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
342#define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
343#define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
344#define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
12bcd1a6 345
3b9e3074
SH
346#define packWARN(a) (a )
347#define packWARN2(a,b) ((a) | ((b)<<8) )
348#define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
349#define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
12bcd1a6
PM
350
351#define unpackWARN1(x) ((x) & 0xFF)
352#define unpackWARN2(x) (((x) >>8) & 0xFF)
353#define unpackWARN3(x) (((x) >>16) & 0xFF)
354#define unpackWARN4(x) (((x) >>24) & 0xFF)
355
356#define ckDEAD(x) \
357 ( ! specialWARN(PL_curcop->cop_warnings) && \
358 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
359 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
360 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
361 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
362 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
363
4438c4b7 364/* end of file warnings.h */
37442d52 365/* ex: set ro: */
599cee73
PM
366EOM
367
368close WARN ;
369
370while (<DATA>) {
371 last if /^KEYWORDS$/ ;
372 print PM $_ ;
373}
374
d3a7d8c7
GS
375#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
376
0d658bf5 377$last_ver = 0;
53c33732 378print PM "our %Offsets = (\n" ;
0d658bf5
PM
379foreach my $k (sort { $a <=> $b } keys %ValueToName) {
380 my ($name, $version) = @{ $ValueToName{$k} };
381 $name = lc $name;
d3a7d8c7 382 $k *= 2 ;
0d658bf5
PM
383 if ( $last_ver != $version ) {
384 print PM "\n";
385 print PM tab(4, " # Warnings Categories added in Perl $version");
386 print PM "\n\n";
387 }
388 print PM tab(4, " '$name'"), "=> $k,\n" ;
389 $last_ver = $version;
d3a7d8c7
GS
390}
391
392print PM " );\n\n" ;
393
53c33732 394print PM "our %Bits = (\n" ;
599cee73
PM
395foreach $k (sort keys %list) {
396
397 my $v = $list{$k} ;
398 my @list = sort { $a <=> $b } @$v ;
399
0ca4541c
NIS
400 print PM tab(4, " '$k'"), '=> "',
401 # mkHex($warn_size, @list),
402 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
403 '", # [', mkRange(@list), "]\n" ;
404}
405
406print PM " );\n\n" ;
407
53c33732 408print PM "our %DeadBits = (\n" ;
599cee73
PM
409foreach $k (sort keys %list) {
410
411 my $v = $list{$k} ;
412 my @list = sort { $a <=> $b } @$v ;
413
0ca4541c
NIS
414 print PM tab(4, " '$k'"), '=> "',
415 # mkHex($warn_size, @list),
416 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
417 '", # [', mkRange(@list), "]\n" ;
418}
419
420print PM " );\n\n" ;
d3a7d8c7
GS
421print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
422print PM '$LAST_BIT = ' . "$index ;\n" ;
423print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73
PM
424while (<DATA>) {
425 print PM $_ ;
426}
427
37442d52 428print PM "# ex: set ro:\n";
599cee73
PM
429close PM ;
430
431__END__
37442d52 432# -*- buffer-read-only: t -*-
38875929 433# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 434# This file was created by warnings.pl
599cee73
PM
435# Any changes made here will be lost.
436#
437
4438c4b7 438package warnings;
599cee73 439
f2c3e829
RGS
440our $VERSION = '1.06';
441
442# Verify that we're called correctly so that warnings will work.
443# see also strict.pm.
5108dc18 444unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
f2c3e829 445 my (undef, $f, $l) = caller;
5108dc18 446 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
f2c3e829 447}
b75c8c73 448
599cee73
PM
449=head1 NAME
450
4438c4b7 451warnings - Perl pragma to control optional warnings
599cee73
PM
452
453=head1 SYNOPSIS
454
4438c4b7
JH
455 use warnings;
456 no warnings;
599cee73 457
4438c4b7
JH
458 use warnings "all";
459 no warnings "all";
599cee73 460
d3a7d8c7
GS
461 use warnings::register;
462 if (warnings::enabled()) {
463 warnings::warn("some warning");
464 }
465
466 if (warnings::enabled("void")) {
e476b1b5
GS
467 warnings::warn("void", "some warning");
468 }
469
7e6d00f8
PM
470 if (warnings::enabled($object)) {
471 warnings::warn($object, "some warning");
472 }
473
721f911b
PM
474 warnings::warnif("some warning");
475 warnings::warnif("void", "some warning");
476 warnings::warnif($object, "some warning");
7e6d00f8 477
599cee73
PM
478=head1 DESCRIPTION
479
fe2e802c
EM
480The C<warnings> pragma is a replacement for the command line flag C<-w>,
481but the pragma is limited to the enclosing block, while the flag is global.
482See L<perllexwarn> for more information.
483
0453d815
PM
484If no import list is supplied, all possible warnings are either enabled
485or disabled.
599cee73 486
0ca4541c 487A number of functions are provided to assist module authors.
e476b1b5
GS
488
489=over 4
490
d3a7d8c7
GS
491=item use warnings::register
492
7e6d00f8
PM
493Creates a new warnings category with the same name as the package where
494the call to the pragma is used.
495
496=item warnings::enabled()
497
498Use the warnings category with the same name as the current package.
499
500Return TRUE if that warnings category is enabled in the calling module.
501Otherwise returns FALSE.
502
503=item warnings::enabled($category)
504
505Return TRUE if the warnings category, C<$category>, is enabled in the
506calling module.
507Otherwise returns FALSE.
508
509=item warnings::enabled($object)
510
511Use the name of the class for the object reference, C<$object>, as the
512warnings category.
513
514Return TRUE if that warnings category is enabled in the first scope
515where the object is used.
516Otherwise returns FALSE.
517
518=item warnings::warn($message)
519
520Print C<$message> to STDERR.
521
522Use the warnings category with the same name as the current package.
523
524If that warnings category has been set to "FATAL" in the calling module
525then die. Otherwise return.
526
527=item warnings::warn($category, $message)
528
529Print C<$message> to STDERR.
530
531If the warnings category, C<$category>, has been set to "FATAL" in the
532calling module then die. Otherwise return.
d3a7d8c7 533
7e6d00f8 534=item warnings::warn($object, $message)
e476b1b5 535
7e6d00f8 536Print C<$message> to STDERR.
e476b1b5 537
7e6d00f8
PM
538Use the name of the class for the object reference, C<$object>, as the
539warnings category.
e476b1b5 540
7e6d00f8
PM
541If that warnings category has been set to "FATAL" in the scope where C<$object>
542is first used then die. Otherwise return.
599cee73 543
e476b1b5 544
7e6d00f8
PM
545=item warnings::warnif($message)
546
547Equivalent to:
548
549 if (warnings::enabled())
550 { warnings::warn($message) }
551
552=item warnings::warnif($category, $message)
553
554Equivalent to:
555
556 if (warnings::enabled($category))
557 { warnings::warn($category, $message) }
558
559=item warnings::warnif($object, $message)
560
561Equivalent to:
562
563 if (warnings::enabled($object))
564 { warnings::warn($object, $message) }
d3a7d8c7 565
e476b1b5
GS
566=back
567
749f83fa 568See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
569
570=cut
571
599cee73
PM
572KEYWORDS
573
d3a7d8c7
GS
574$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
575
c3186b65
PM
576sub Croaker
577{
29ddba3b 578 require Carp::Heavy; # this initializes %CarpInternal
dbab294c 579 local $Carp::CarpInternal{'warnings'};
c3186b65 580 delete $Carp::CarpInternal{'warnings'};
8becbb3b 581 Carp::croak(@_);
c3186b65
PM
582}
583
6e9af7e4
PM
584sub bits
585{
586 # called from B::Deparse.pm
587
588 push @_, 'all' unless @_;
589
590 my $mask;
599cee73
PM
591 my $catmask ;
592 my $fatal = 0 ;
6e9af7e4
PM
593 my $no_fatal = 0 ;
594
595 foreach my $word ( @_ ) {
596 if ($word eq 'FATAL') {
327afb7f 597 $fatal = 1;
6e9af7e4
PM
598 $no_fatal = 0;
599 }
600 elsif ($word eq 'NONFATAL') {
601 $fatal = 0;
602 $no_fatal = 1;
327afb7f 603 }
d3a7d8c7
GS
604 elsif ($catmask = $Bits{$word}) {
605 $mask |= $catmask ;
606 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 607 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 608 }
d3a7d8c7 609 else
c3186b65 610 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
611 }
612
613 return $mask ;
614}
615
6e9af7e4
PM
616sub import
617{
599cee73 618 shift;
6e9af7e4
PM
619
620 my $catmask ;
621 my $fatal = 0 ;
622 my $no_fatal = 0 ;
623
f1f33818 624 my $mask = ${^WARNING_BITS} ;
6e9af7e4 625
f1f33818
PM
626 if (vec($mask, $Offsets{'all'}, 1)) {
627 $mask |= $Bits{'all'} ;
628 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
629 }
6e9af7e4
PM
630
631 push @_, 'all' unless @_;
632
633 foreach my $word ( @_ ) {
634 if ($word eq 'FATAL') {
635 $fatal = 1;
636 $no_fatal = 0;
637 }
638 elsif ($word eq 'NONFATAL') {
639 $fatal = 0;
640 $no_fatal = 1;
641 }
642 elsif ($catmask = $Bits{$word}) {
643 $mask |= $catmask ;
644 $mask |= $DeadBits{$word} if $fatal ;
645 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
646 }
647 else
648 { Croaker("Unknown warnings category '$word'")}
649 }
650
651 ${^WARNING_BITS} = $mask ;
599cee73
PM
652}
653
6e9af7e4
PM
654sub unimport
655{
599cee73 656 shift;
6e9af7e4
PM
657
658 my $catmask ;
d3a7d8c7 659 my $mask = ${^WARNING_BITS} ;
6e9af7e4 660
d3a7d8c7 661 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 662 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
663 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
664 }
6e9af7e4
PM
665
666 push @_, 'all' unless @_;
667
668 foreach my $word ( @_ ) {
669 if ($word eq 'FATAL') {
670 next;
671 }
672 elsif ($catmask = $Bits{$word}) {
673 $mask &= ~($catmask | $DeadBits{$word} | $All);
674 }
675 else
676 { Croaker("Unknown warnings category '$word'")}
677 }
678
679 ${^WARNING_BITS} = $mask ;
599cee73
PM
680}
681
9df0f64f 682my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
683
7e6d00f8 684sub __chk
599cee73 685{
d3a7d8c7
GS
686 my $category ;
687 my $offset ;
7e6d00f8 688 my $isobj = 0 ;
d3a7d8c7
GS
689
690 if (@_) {
691 # check the category supplied.
692 $category = shift ;
9df0f64f 693 if (my $type = ref $category) {
694 Croaker("not an object")
695 if exists $builtin_type{$type};
696 $category = $type;
7e6d00f8
PM
697 $isobj = 1 ;
698 }
d3a7d8c7 699 $offset = $Offsets{$category};
c3186b65 700 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
701 unless defined $offset;
702 }
703 else {
0ca4541c 704 $category = (caller(1))[0] ;
d3a7d8c7 705 $offset = $Offsets{$category};
c3186b65 706 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
707 unless defined $offset ;
708 }
709
0ca4541c 710 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
711 my $i = 2 ;
712 my $pkg ;
713
714 if ($isobj) {
715 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
716 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
717 }
718 $i -= 2 ;
719 }
720 else {
4f527b71 721 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
722 }
723
0ca4541c 724 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
725 return ($callers_bitmask, $offset, $i) ;
726}
727
4f527b71
AS
728sub _error_loc {
729 require Carp::Heavy;
730 goto &Carp::short_error_loc; # don't introduce another stack frame
731}
732
7e6d00f8
PM
733sub enabled
734{
c3186b65 735 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
736 unless @_ == 1 || @_ == 0 ;
737
738 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
739
740 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
741 return vec($callers_bitmask, $offset, 1) ||
742 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
743}
744
d3a7d8c7 745
e476b1b5
GS
746sub warn
747{
c3186b65 748 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 749 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 750
7e6d00f8
PM
751 my $message = pop ;
752 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
09e96b99 753 require Carp;
8becbb3b 754 Carp::croak($message)
d3a7d8c7
GS
755 if vec($callers_bitmask, $offset+1, 1) ||
756 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
8becbb3b 757 Carp::carp($message) ;
e476b1b5
GS
758}
759
7e6d00f8
PM
760sub warnif
761{
c3186b65 762 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
763 unless @_ == 2 || @_ == 1 ;
764
765 my $message = pop ;
766 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 767
0ca4541c 768 return
7e6d00f8
PM
769 unless defined $callers_bitmask &&
770 (vec($callers_bitmask, $offset, 1) ||
771 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
772
09e96b99 773 require Carp;
8becbb3b 774 Carp::croak($message)
7e6d00f8
PM
775 if vec($callers_bitmask, $offset+1, 1) ||
776 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
777
8becbb3b 778 Carp::carp($message) ;
7e6d00f8 779}
0d658bf5 780
599cee73 7811;