This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
doc tweak (from Michael G Schwern <schwern@pobox.com>)
[perl5.git] / warnings.pl
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
73f0cc2d
GS
3BEGIN {
4 push @INC, './lib';
5}
599cee73
PM
6use strict ;
7
8sub DEFAULT_ON () { 1 }
9sub DEFAULT_OFF () { 2 }
10
11my $tree = {
12 'unsafe' => { 'untie' => DEFAULT_OFF,
13 'substr' => DEFAULT_OFF,
14 'taint' => DEFAULT_OFF,
15 'signal' => DEFAULT_OFF,
16 'closure' => DEFAULT_OFF,
627300f0
JH
17 'overflow' => DEFAULT_OFF,
18 'portable' => DEFAULT_OFF,
599cee73
PM
19 'utf8' => DEFAULT_OFF,
20 } ,
21 'io' => { 'pipe' => DEFAULT_OFF,
22 'unopened' => DEFAULT_OFF,
23 'closed' => DEFAULT_OFF,
24 'newline' => DEFAULT_OFF,
25 'exec' => DEFAULT_OFF,
26 #'wr in in file'=> DEFAULT_OFF,
27 },
28 'syntax' => { 'ambiguous' => DEFAULT_OFF,
29 'semicolon' => DEFAULT_OFF,
30 'precedence' => DEFAULT_OFF,
31 'reserved' => DEFAULT_OFF,
32 'octal' => DEFAULT_OFF,
627300f0 33 'digit' => DEFAULT_OFF,
599cee73
PM
34 'parenthesis' => DEFAULT_OFF,
35 'deprecated' => DEFAULT_OFF,
36 'printf' => DEFAULT_OFF,
37 },
0453d815
PM
38 'severe' => { 'inplace' => DEFAULT_ON,
39 'internal' => DEFAULT_ON,
40 'debugging' => DEFAULT_ON,
41 },
599cee73
PM
42 'void' => DEFAULT_OFF,
43 'recursion' => DEFAULT_OFF,
44 'redefine' => DEFAULT_OFF,
45 'numeric' => DEFAULT_OFF,
46 'uninitialized'=> DEFAULT_OFF,
47 'once' => DEFAULT_OFF,
48 'misc' => DEFAULT_OFF,
0453d815 49 #'default' => DEFAULT_ON,
599cee73
PM
50 } ;
51
52
53###########################################################################
54sub tab {
55 my($l, $t) = @_;
56 $t .= "\t" x ($l - (length($t) + 1) / 8);
57 $t;
58}
59
60###########################################################################
61
62my %list ;
63my %Value ;
64my $index = 0 ;
65
66sub walk
67{
68 my $tre = shift ;
69 my @list = () ;
70 my ($k, $v) ;
71
95dfd3ab
GS
72 foreach $k (sort keys %$tre) {
73 $v = $tre->{$k};
599cee73
PM
74 die "duplicate key $k\n" if defined $list{$k} ;
75 $Value{$index} = uc $k ;
76 push @{ $list{$k} }, $index ++ ;
77 if (ref $v)
78 { push (@{ $list{$k} }, walk ($v)) }
79 push @list, @{ $list{$k} } ;
80 }
81
82 return @list ;
599cee73
PM
83}
84
85###########################################################################
86
87sub mkRange
88{
89 my @a = @_ ;
90 my @out = @a ;
91 my $i ;
92
93
94 for ($i = 1 ; $i < @a; ++ $i) {
95 $out[$i] = ".."
96 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
97 }
98
99 my $out = join(",",@out);
100
101 $out =~ s/,(\.\.,)+/../g ;
102 return $out;
103}
104
105###########################################################################
106
107sub mkHex
108{
109 my ($max, @a) = @_ ;
110 my $mask = "\x00" x $max ;
111 my $string = "" ;
112
113 foreach (@a) {
114 vec($mask, $_, 1) = 1 ;
115 }
116
117 #$string = unpack("H$max", $mask) ;
118 #$string =~ s/(..)/\x$1/g;
119 foreach (unpack("C*", $mask)) {
120 $string .= '\x' . sprintf("%2.2x", $_) ;
121 }
122 return $string ;
123}
124
125###########################################################################
126
127
4438c4b7
JH
128#unlink "warnings.h";
129#unlink "lib/warnings.pm";
130open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
131open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
599cee73
PM
132
133print WARN <<'EOM' ;
134/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 135 This file is built by warnings.pl
599cee73
PM
136 Any changes made here will be lost!
137*/
138
139
0453d815
PM
140#define Off(x) ((x) / 8)
141#define Bit(x) (1 << ((x) % 8))
599cee73
PM
142#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
143
0453d815 144
599cee73 145#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 146#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
147#define G_WARN_ALL_ON 2 /* -W flag */
148#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 149#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
150#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
151
0453d815 152#define WARN_STD Nullsv
971a9dd3
GS
153#define WARN_ALL (Nullsv+1) /* use warnings 'all' */
154#define WARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73 155
0453d815
PM
156#define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \
157 (x) == WARN_NONE)
599cee73
PM
158
159#define ckDEAD(x) \
0453d815 160 ( ! specialWARN(PL_curcop->cop_warnings) && \
e24b16f9 161 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
599cee73
PM
162
163#define ckWARN(x) \
0453d815
PM
164 ( (PL_curcop->cop_warnings != WARN_STD && \
165 PL_curcop->cop_warnings != WARN_NONE && \
e24b16f9
GS
166 (PL_curcop->cop_warnings == WARN_ALL || \
167 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \
0453d815 168 || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
599cee73
PM
169
170#define ckWARN2(x,y) \
0453d815
PM
171 ( (PL_curcop->cop_warnings != WARN_STD && \
172 PL_curcop->cop_warnings != WARN_NONE && \
e24b16f9
GS
173 (PL_curcop->cop_warnings == WARN_ALL || \
174 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
175 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \
0453d815 176 || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
599cee73 177
0453d815
PM
178#define ckWARN_d(x) \
179 (PL_curcop->cop_warnings == WARN_STD || \
180 PL_curcop->cop_warnings == WARN_ALL || \
181 (PL_curcop->cop_warnings != WARN_NONE && \
182 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
599cee73 183
0453d815
PM
184#define ckWARN2_d(x,y) \
185 (PL_curcop->cop_warnings == WARN_STD || \
186 PL_curcop->cop_warnings == WARN_ALL || \
187 (PL_curcop->cop_warnings != WARN_NONE && \
188 (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
189 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
599cee73 190
599cee73 191
0453d815
PM
192#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD)
193#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD)
194#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
195#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
599cee73
PM
196
197EOM
198
199
200$index = 0 ;
201@{ $list{"all"} } = walk ($tree) ;
202
203$index *= 2 ;
204my $warn_size = int($index / 8) + ($index % 8 != 0) ;
205
206my $k ;
207foreach $k (sort { $a <=> $b } keys %Value) {
208 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
209}
210print WARN "\n" ;
211
212print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
213#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
214print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
215print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
216
217print WARN <<'EOM';
218
4438c4b7 219/* end of file warnings.h */
599cee73
PM
220
221EOM
222
223close WARN ;
224
225while (<DATA>) {
226 last if /^KEYWORDS$/ ;
227 print PM $_ ;
228}
229
230$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
231print PM "%Bits = (\n" ;
232foreach $k (sort keys %list) {
233
234 my $v = $list{$k} ;
235 my @list = sort { $a <=> $b } @$v ;
236
237 print PM tab(4, " '$k'"), '=> "',
238 # mkHex($warn_size, @list),
239 mkHex($warn_size, map $_ * 2 , @list),
240 '", # [', mkRange(@list), "]\n" ;
241}
242
243print PM " );\n\n" ;
244
245print PM "%DeadBits = (\n" ;
246foreach $k (sort keys %list) {
247
248 my $v = $list{$k} ;
249 my @list = sort { $a <=> $b } @$v ;
250
251 print PM tab(4, " '$k'"), '=> "',
252 # mkHex($warn_size, @list),
253 mkHex($warn_size, map $_ * 2 + 1 , @list),
254 '", # [', mkRange(@list), "]\n" ;
255}
256
257print PM " );\n\n" ;
258while (<DATA>) {
259 print PM $_ ;
260}
261
262close PM ;
263
264__END__
265
4438c4b7 266# This file was created by warnings.pl
599cee73
PM
267# Any changes made here will be lost.
268#
269
4438c4b7 270package warnings;
599cee73
PM
271
272=head1 NAME
273
4438c4b7 274warnings - Perl pragma to control optional warnings
599cee73
PM
275
276=head1 SYNOPSIS
277
4438c4b7
JH
278 use warnings;
279 no warnings;
599cee73 280
4438c4b7
JH
281 use warnings "all";
282 no warnings "all";
599cee73
PM
283
284=head1 DESCRIPTION
285
0453d815
PM
286If no import list is supplied, all possible warnings are either enabled
287or disabled.
599cee73 288
0453d815 289See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
290
291
292=cut
293
294use Carp ;
295
296KEYWORDS
297
298sub bits {
299 my $mask ;
300 my $catmask ;
301 my $fatal = 0 ;
302 foreach my $word (@_) {
303 if ($word eq 'FATAL')
304 { $fatal = 1 }
305 elsif ($catmask = $Bits{$word}) {
306 $mask |= $catmask ;
307 $mask |= $DeadBits{$word} if $fatal ;
308 }
309 else
310 { croak "unknown warning category '$word'" }
311 }
312
313 return $mask ;
314}
315
316sub import {
317 shift;
4438c4b7 318 ${^Warnings} |= bits(@_ ? @_ : 'all') ;
599cee73
PM
319}
320
321sub unimport {
322 shift;
4438c4b7 323 ${^Warnings} &= ~ bits(@_ ? @_ : 'all') ;
599cee73
PM
324}
325
326sub enabled
327{
328 my $string = shift ;
329
330 return 1
4438c4b7 331 if $bits{$string} && ${^Warnings} & $bits{$string} ;
599cee73
PM
332
333 return 0 ;
334}
335
3361;