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