This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid compiler warnings
[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 = {
e476b1b5 12 'io' => { 'pipe' => DEFAULT_OFF,
599cee73
PM
13 'unopened' => DEFAULT_OFF,
14 'closed' => DEFAULT_OFF,
15 'newline' => DEFAULT_OFF,
16 'exec' => DEFAULT_OFF,
599cee73 17 },
e476b1b5 18 'syntax' => { 'ambiguous' => DEFAULT_OFF,
599cee73 19 'semicolon' => DEFAULT_OFF,
e476b1b5 20 'precedence' => DEFAULT_OFF,
4673fc70 21 'bareword' => DEFAULT_OFF,
599cee73 22 'reserved' => DEFAULT_OFF,
627300f0 23 'digit' => DEFAULT_OFF,
599cee73
PM
24 'parenthesis' => DEFAULT_OFF,
25 'deprecated' => DEFAULT_OFF,
26 'printf' => DEFAULT_OFF,
e476b1b5
GS
27 'prototype' => DEFAULT_OFF,
28 'qw' => DEFAULT_OFF,
599cee73 29 },
e476b1b5 30 'severe' => { 'inplace' => DEFAULT_ON,
0453d815
PM
31 'internal' => DEFAULT_ON,
32 'debugging' => DEFAULT_ON,
e476b1b5 33 'malloc' => DEFAULT_ON,
0453d815 34 },
e476b1b5
GS
35 'void' => DEFAULT_OFF,
36 'recursion' => DEFAULT_OFF,
37 'redefine' => DEFAULT_OFF,
38 'numeric' => DEFAULT_OFF,
39 'uninitialized' => DEFAULT_OFF,
40 'once' => DEFAULT_OFF,
41 'misc' => DEFAULT_OFF,
42 'regexp' => DEFAULT_OFF,
43 'glob' => DEFAULT_OFF,
44 'y2k' => DEFAULT_OFF,
45 'chmod' => DEFAULT_OFF,
46 'umask' => DEFAULT_OFF,
47 'untie' => DEFAULT_OFF,
48 'substr' => DEFAULT_OFF,
49 'taint' => DEFAULT_OFF,
50 'signal' => DEFAULT_OFF,
51 'closure' => DEFAULT_OFF,
52 'overflow' => DEFAULT_OFF,
53 'portable' => DEFAULT_OFF,
54 'utf8' => DEFAULT_OFF,
55 'exiting' => DEFAULT_OFF,
56 'pack' => DEFAULT_OFF,
57 'unpack' => DEFAULT_OFF,
0453d815 58 #'default' => DEFAULT_ON,
599cee73
PM
59 } ;
60
61
62###########################################################################
63sub tab {
64 my($l, $t) = @_;
65 $t .= "\t" x ($l - (length($t) + 1) / 8);
66 $t;
67}
68
69###########################################################################
70
71my %list ;
72my %Value ;
73my $index = 0 ;
74
75sub walk
76{
77 my $tre = shift ;
78 my @list = () ;
79 my ($k, $v) ;
80
95dfd3ab
GS
81 foreach $k (sort keys %$tre) {
82 $v = $tre->{$k};
599cee73
PM
83 die "duplicate key $k\n" if defined $list{$k} ;
84 $Value{$index} = uc $k ;
85 push @{ $list{$k} }, $index ++ ;
86 if (ref $v)
87 { push (@{ $list{$k} }, walk ($v)) }
88 push @list, @{ $list{$k} } ;
89 }
90
91 return @list ;
599cee73
PM
92}
93
94###########################################################################
95
96sub mkRange
97{
98 my @a = @_ ;
99 my @out = @a ;
100 my $i ;
101
102
103 for ($i = 1 ; $i < @a; ++ $i) {
104 $out[$i] = ".."
105 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
106 }
107
108 my $out = join(",",@out);
109
110 $out =~ s/,(\.\.,)+/../g ;
111 return $out;
112}
113
114###########################################################################
e476b1b5
GS
115sub printTree
116{
117 my $tre = shift ;
118 my $prefix = shift ;
119 my $indent = shift ;
120 my ($k, $v) ;
121
122 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
123
124 $prefix .= " " x $indent ;
125 foreach $k (sort keys %$tre) {
126 $v = $tre->{$k};
127 print $prefix . "|\n" ;
128 print $prefix . "+- $k" ;
129 if (ref $v)
130 {
131 print " " . "-" x ($max - length $k ) . "+\n" ;
132 printTree ($v, $prefix . "|" , $max + $indent - 1)
133 }
134 else
135 { print "\n" }
136 }
137
138}
139
140###########################################################################
599cee73
PM
141
142sub mkHex
143{
144 my ($max, @a) = @_ ;
145 my $mask = "\x00" x $max ;
146 my $string = "" ;
147
148 foreach (@a) {
149 vec($mask, $_, 1) = 1 ;
150 }
151
152 #$string = unpack("H$max", $mask) ;
153 #$string =~ s/(..)/\x$1/g;
154 foreach (unpack("C*", $mask)) {
155 $string .= '\x' . sprintf("%2.2x", $_) ;
156 }
157 return $string ;
158}
159
160###########################################################################
161
e476b1b5
GS
162if (@ARGV && $ARGV[0] eq "tree")
163{
164 print " all -+\n" ;
165 printTree($tree, " ", 4) ;
166 exit ;
167}
599cee73 168
4438c4b7
JH
169#unlink "warnings.h";
170#unlink "lib/warnings.pm";
171open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
172open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
599cee73
PM
173
174print WARN <<'EOM' ;
175/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 176 This file is built by warnings.pl
599cee73
PM
177 Any changes made here will be lost!
178*/
179
180
0453d815
PM
181#define Off(x) ((x) / 8)
182#define Bit(x) (1 << ((x) % 8))
599cee73
PM
183#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
184
0453d815 185
599cee73 186#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 187#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
188#define G_WARN_ALL_ON 2 /* -W flag */
189#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 190#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
191#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
192
0453d815 193#define WARN_STD Nullsv
971a9dd3
GS
194#define WARN_ALL (Nullsv+1) /* use warnings 'all' */
195#define WARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73 196
0453d815
PM
197#define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \
198 (x) == WARN_NONE)
599cee73
PM
199
200#define ckDEAD(x) \
0453d815 201 ( ! specialWARN(PL_curcop->cop_warnings) && \
e24b16f9 202 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
599cee73
PM
203
204#define ckWARN(x) \
0453d815
PM
205 ( (PL_curcop->cop_warnings != WARN_STD && \
206 PL_curcop->cop_warnings != WARN_NONE && \
e24b16f9
GS
207 (PL_curcop->cop_warnings == WARN_ALL || \
208 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \
0453d815 209 || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
599cee73
PM
210
211#define ckWARN2(x,y) \
0453d815
PM
212 ( (PL_curcop->cop_warnings != WARN_STD && \
213 PL_curcop->cop_warnings != WARN_NONE && \
e24b16f9
GS
214 (PL_curcop->cop_warnings == WARN_ALL || \
215 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
216 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \
0453d815 217 || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
599cee73 218
0453d815
PM
219#define ckWARN_d(x) \
220 (PL_curcop->cop_warnings == WARN_STD || \
221 PL_curcop->cop_warnings == WARN_ALL || \
222 (PL_curcop->cop_warnings != WARN_NONE && \
223 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
599cee73 224
0453d815
PM
225#define ckWARN2_d(x,y) \
226 (PL_curcop->cop_warnings == WARN_STD || \
227 PL_curcop->cop_warnings == WARN_ALL || \
228 (PL_curcop->cop_warnings != WARN_NONE && \
229 (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
230 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
599cee73 231
599cee73 232
0453d815
PM
233#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD)
234#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD)
235#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
236#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
599cee73
PM
237
238EOM
239
240
241$index = 0 ;
242@{ $list{"all"} } = walk ($tree) ;
243
244$index *= 2 ;
245my $warn_size = int($index / 8) + ($index % 8 != 0) ;
246
247my $k ;
248foreach $k (sort { $a <=> $b } keys %Value) {
249 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
250}
251print WARN "\n" ;
252
253print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
254#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
255print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
256print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
257
258print WARN <<'EOM';
259
4438c4b7 260/* end of file warnings.h */
599cee73
PM
261
262EOM
263
264close WARN ;
265
266while (<DATA>) {
267 last if /^KEYWORDS$/ ;
268 print PM $_ ;
269}
270
271$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
272print PM "%Bits = (\n" ;
273foreach $k (sort keys %list) {
274
275 my $v = $list{$k} ;
276 my @list = sort { $a <=> $b } @$v ;
277
278 print PM tab(4, " '$k'"), '=> "',
279 # mkHex($warn_size, @list),
280 mkHex($warn_size, map $_ * 2 , @list),
281 '", # [', mkRange(@list), "]\n" ;
282}
283
284print PM " );\n\n" ;
285
286print PM "%DeadBits = (\n" ;
287foreach $k (sort keys %list) {
288
289 my $v = $list{$k} ;
290 my @list = sort { $a <=> $b } @$v ;
291
292 print PM tab(4, " '$k'"), '=> "',
293 # mkHex($warn_size, @list),
294 mkHex($warn_size, map $_ * 2 + 1 , @list),
295 '", # [', mkRange(@list), "]\n" ;
296}
297
298print PM " );\n\n" ;
e476b1b5 299print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
599cee73
PM
300while (<DATA>) {
301 print PM $_ ;
302}
303
304close PM ;
305
306__END__
307
4438c4b7 308# This file was created by warnings.pl
599cee73
PM
309# Any changes made here will be lost.
310#
311
4438c4b7 312package warnings;
599cee73
PM
313
314=head1 NAME
315
4438c4b7 316warnings - Perl pragma to control optional warnings
599cee73
PM
317
318=head1 SYNOPSIS
319
4438c4b7
JH
320 use warnings;
321 no warnings;
599cee73 322
4438c4b7
JH
323 use warnings "all";
324 no warnings "all";
599cee73 325
e476b1b5
GS
326 if (warnings::enabled("void") {
327 warnings::warn("void", "some warning");
328 }
329
599cee73
PM
330=head1 DESCRIPTION
331
0453d815
PM
332If no import list is supplied, all possible warnings are either enabled
333or disabled.
599cee73 334
e476b1b5
GS
335Two functions are provided to assist module authors.
336
337=over 4
338
339=item warnings::enabled($category)
340
341Returns TRUE if the warnings category in C<$category> is enabled in the
342calling module. Otherwise returns FALSE.
343
344
345=item warnings::warn($category, $message)
599cee73 346
e476b1b5
GS
347If the calling module has I<not> set C<$category> to "FATAL", print
348C<$message> to STDERR.
349If the calling module has set C<$category> to "FATAL", print C<$message>
350STDERR then die.
351
352=back
353
354See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
355
356=cut
357
358use Carp ;
359
360KEYWORDS
361
362sub bits {
363 my $mask ;
364 my $catmask ;
365 my $fatal = 0 ;
366 foreach my $word (@_) {
327afb7f
GS
367 if ($word eq 'FATAL') {
368 $fatal = 1;
369 }
370 else {
371 if ($catmask = $Bits{$word}) {
372 $mask |= $catmask ;
373 $mask |= $DeadBits{$word} if $fatal ;
374 }
599cee73 375 }
599cee73
PM
376 }
377
378 return $mask ;
379}
380
381sub import {
382 shift;
6a818117 383 ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
599cee73
PM
384}
385
386sub unimport {
387 shift;
6a818117 388 ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
599cee73
PM
389}
390
391sub enabled
392{
e476b1b5
GS
393 # If no parameters, check for any lexical warnings enabled
394 # in the users scope.
395 my $callers_bitmask = (caller(1))[9] ;
396 return ($callers_bitmask ne $NONE) if @_ == 0 ;
397
398 # otherwise check for the category supplied.
399 my $category = shift ;
400 return 0
401 unless $Bits{$category} ;
402 return 0 unless defined $callers_bitmask ;
599cee73 403 return 1
e476b1b5 404 if ($callers_bitmask & $Bits{$category}) ne $NONE ;
599cee73
PM
405
406 return 0 ;
407}
408
e476b1b5
GS
409sub warn
410{
411 croak "Usage: warnings::warn('category', 'message')"
412 unless @_ == 2 ;
413 my $category = shift ;
414 my $message = shift ;
415 local $Carp::CarpLevel = 1 ;
416 my $callers_bitmask = (caller(1))[9] ;
417 croak($message)
418 if defined $callers_bitmask &&
419 ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
420 carp($message) ;
421}
422
599cee73 4231;