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