This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Patch to JPL example program
[perl5.git] / warning.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,
17 'utf8' => DEFAULT_OFF,
18 } ,
19 'io' => { 'pipe' => DEFAULT_OFF,
20 'unopened' => DEFAULT_OFF,
21 'closed' => DEFAULT_OFF,
22 'newline' => DEFAULT_OFF,
23 'exec' => DEFAULT_OFF,
24 #'wr in in file'=> DEFAULT_OFF,
25 },
26 'syntax' => { 'ambiguous' => DEFAULT_OFF,
27 'semicolon' => DEFAULT_OFF,
28 'precedence' => DEFAULT_OFF,
29 'reserved' => DEFAULT_OFF,
30 'octal' => DEFAULT_OFF,
31 'parenthesis' => DEFAULT_OFF,
32 'deprecated' => DEFAULT_OFF,
33 'printf' => DEFAULT_OFF,
34 },
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 'default' => DEFAULT_ON,
43 } ;
44
45
46###########################################################################
47sub tab {
48 my($l, $t) = @_;
49 $t .= "\t" x ($l - (length($t) + 1) / 8);
50 $t;
51}
52
53###########################################################################
54
55my %list ;
56my %Value ;
57my $index = 0 ;
58
59sub walk
60{
61 my $tre = shift ;
62 my @list = () ;
63 my ($k, $v) ;
64
95dfd3ab
GS
65 foreach $k (sort keys %$tre) {
66 $v = $tre->{$k};
599cee73
PM
67 die "duplicate key $k\n" if defined $list{$k} ;
68 $Value{$index} = uc $k ;
69 push @{ $list{$k} }, $index ++ ;
70 if (ref $v)
71 { push (@{ $list{$k} }, walk ($v)) }
72 push @list, @{ $list{$k} } ;
73 }
74
75 return @list ;
599cee73
PM
76}
77
78###########################################################################
79
80sub mkRange
81{
82 my @a = @_ ;
83 my @out = @a ;
84 my $i ;
85
86
87 for ($i = 1 ; $i < @a; ++ $i) {
88 $out[$i] = ".."
89 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
90 }
91
92 my $out = join(",",@out);
93
94 $out =~ s/,(\.\.,)+/../g ;
95 return $out;
96}
97
98###########################################################################
99
100sub mkHex
101{
102 my ($max, @a) = @_ ;
103 my $mask = "\x00" x $max ;
104 my $string = "" ;
105
106 foreach (@a) {
107 vec($mask, $_, 1) = 1 ;
108 }
109
110 #$string = unpack("H$max", $mask) ;
111 #$string =~ s/(..)/\x$1/g;
112 foreach (unpack("C*", $mask)) {
113 $string .= '\x' . sprintf("%2.2x", $_) ;
114 }
115 return $string ;
116}
117
118###########################################################################
119
120
121#unlink "warning.h";
122#unlink "lib/warning.pm";
123open(WARN, ">warning.h") || die "Can't create warning.h: $!\n";
124open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n";
125
126print WARN <<'EOM' ;
127/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
128 This file is built by warning.pl
129 Any changes made here will be lost!
130*/
131
132
133#define Off(x) ((x) / 8)
134#define Bit(x) (1 << ((x) % 8))
135#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
136
137#define G_WARN_OFF 0 /* $^W == 0 */
138#define G_WARN_ON 1 /* $^W != 0 */
139#define G_WARN_ALL_ON 2 /* -W flag */
140#define G_WARN_ALL_OFF 4 /* -X flag */
141#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
142
143#if 1
144
145/* Part of the logic below assumes that WARN_NONE is NULL */
146
147#define ckDEAD(x) \
e24b16f9
GS
148 (PL_curcop->cop_warnings != WARN_ALL && \
149 PL_curcop->cop_warnings != WARN_NONE && \
150 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
599cee73
PM
151
152#define ckWARN(x) \
e24b16f9
GS
153 ( (PL_curcop->cop_warnings && \
154 (PL_curcop->cop_warnings == WARN_ALL || \
155 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \
599cee73
PM
156 || (PL_dowarn & G_WARN_ON) )
157
158#define ckWARN2(x,y) \
e24b16f9
GS
159 ( (PL_curcop->cop_warnings && \
160 (PL_curcop->cop_warnings == WARN_ALL || \
161 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
162 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \
599cee73
PM
163 || (PL_dowarn & G_WARN_ON) )
164
165#else
166
e24b16f9
GS
167#define ckDEAD(x) \
168 (PL_curcop->cop_warnings != WARN_ALL && \
169 PL_curcop->cop_warnings != WARN_NONE && \
170 SvPVX(PL_curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) )
599cee73 171
e24b16f9 172#define ckWARN(x) \
599cee73 173 ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \
e24b16f9
GS
174 PL_curcop->cop_warnings && \
175 ( PL_curcop->cop_warnings == WARN_ALL || \
176 SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) )
599cee73 177
e24b16f9 178#define ckWARN2(x,y) \
599cee73 179 ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \
e24b16f9
GS
180 PL_curcop->cop_warnings && \
181 ( PL_curcop->cop_warnings == WARN_ALL || \
182 SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \
183 SvPVX(PL_curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) )
599cee73
PM
184
185#endif
186
187#define WARN_NONE NULL
e24b16f9 188#define WARN_ALL (&PL_sv_yes)
599cee73
PM
189
190EOM
191
192
193$index = 0 ;
194@{ $list{"all"} } = walk ($tree) ;
195
196$index *= 2 ;
197my $warn_size = int($index / 8) + ($index % 8 != 0) ;
198
199my $k ;
200foreach $k (sort { $a <=> $b } keys %Value) {
201 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
202}
203print WARN "\n" ;
204
205print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
206#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
207print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
208print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
209
210print WARN <<'EOM';
211
212/* end of file warning.h */
213
214EOM
215
216close WARN ;
217
218while (<DATA>) {
219 last if /^KEYWORDS$/ ;
220 print PM $_ ;
221}
222
223$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
224print PM "%Bits = (\n" ;
225foreach $k (sort keys %list) {
226
227 my $v = $list{$k} ;
228 my @list = sort { $a <=> $b } @$v ;
229
230 print PM tab(4, " '$k'"), '=> "',
231 # mkHex($warn_size, @list),
232 mkHex($warn_size, map $_ * 2 , @list),
233 '", # [', mkRange(@list), "]\n" ;
234}
235
236print PM " );\n\n" ;
237
238print PM "%DeadBits = (\n" ;
239foreach $k (sort keys %list) {
240
241 my $v = $list{$k} ;
242 my @list = sort { $a <=> $b } @$v ;
243
244 print PM tab(4, " '$k'"), '=> "',
245 # mkHex($warn_size, @list),
246 mkHex($warn_size, map $_ * 2 + 1 , @list),
247 '", # [', mkRange(@list), "]\n" ;
248}
249
250print PM " );\n\n" ;
251while (<DATA>) {
252 print PM $_ ;
253}
254
255close PM ;
256
257__END__
258
259# This file was created by warning.pl
260# Any changes made here will be lost.
261#
262
263package warning;
264
265=head1 NAME
266
4c97a74d 267warning - Perl pragma to control optional warnings
599cee73
PM
268
269=head1 SYNOPSIS
270
271 use warning;
272
273 use warning "all";
274 use warning "deprecated";
275
276 use warning;
277 no warning "unsafe";
278
279=head1 DESCRIPTION
280
281If no import list is supplied, all possible restrictions are assumed.
282(This is the safest mode to operate in, but is sometimes too strict for
283casual programming.) Currently, there are three possible things to be
284strict about:
285
286=over 6
287
288=item C<warning deprecated>
289
290This generates a runtime error if you use deprecated
291
292 use warning 'deprecated';
293
294=back
295
296See L<perlmod/Pragmatic Modules>.
297
298
299=cut
300
301use Carp ;
302
303KEYWORDS
304
305sub bits {
306 my $mask ;
307 my $catmask ;
308 my $fatal = 0 ;
309 foreach my $word (@_) {
310 if ($word eq 'FATAL')
311 { $fatal = 1 }
312 elsif ($catmask = $Bits{$word}) {
313 $mask |= $catmask ;
314 $mask |= $DeadBits{$word} if $fatal ;
315 }
316 else
317 { croak "unknown warning category '$word'" }
318 }
319
320 return $mask ;
321}
322
323sub import {
324 shift;
325 $^B |= bits(@_ ? @_ : 'all') ;
326}
327
328sub unimport {
329 shift;
330 $^B &= ~ bits(@_ ? @_ : 'all') ;
331}
332
333
334sub make_fatal
335{
336 my $self = shift ;
337 my $bitmask = $self->bits(@_) ;
338 $SIG{__WARN__} =
339 sub
340 {
341 die @_ if $^B & $bitmask ;
342 warn @_
343 } ;
344}
345
346sub bitmask
347{
348 return $^B ;
349}
350
351sub enabled
352{
353 my $string = shift ;
354
355 return 1
356 if $bits{$string} && $^B & $bits{$string} ;
357
358 return 0 ;
359}
360
3611;