This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change #2487 aftershock.
[perl5.git] / warning.pl
1 #!/usr/bin/perl
2
3 BEGIN {
4   push @INC, './lib';
5 }
6 use strict ;
7
8 sub DEFAULT_ON  () { 1 }
9 sub DEFAULT_OFF () { 2 }
10
11 my $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 ###########################################################################
47 sub tab {
48     my($l, $t) = @_;
49     $t .= "\t" x ($l - (length($t) + 1) / 8);
50     $t;
51 }
52
53 ###########################################################################
54
55 my %list ;
56 my %Value ;
57 my $index = 0 ;
58
59 sub walk
60 {
61     my $tre = shift ;
62     my @list = () ;
63     my ($k, $v) ;
64
65     foreach $k (sort keys %$tre) {
66         $v = $tre->{$k};
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 ;
76 }
77
78 ###########################################################################
79
80 sub 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
100 sub 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";
123 open(WARN, ">warning.h") || die "Can't create warning.h: $!\n";
124 open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n";
125
126 print 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)                                                       \
148            (PL_curcop->cop_warnings != WARN_ALL &&                      \
149             PL_curcop->cop_warnings != WARN_NONE &&                     \
150             IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
151
152 #define ckWARN(x)                                                       \
153         ( (PL_curcop->cop_warnings &&                                   \
154               (PL_curcop->cop_warnings == WARN_ALL ||                   \
155                IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )           \
156           || (PL_dowarn & G_WARN_ON) )
157
158 #define ckWARN2(x,y)                                                    \
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) ) )          \
163             ||  (PL_dowarn & G_WARN_ON) )
164
165 #else
166
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) )
171
172 #define ckWARN(x)                                                       \
173         ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) &&  \
174           PL_curcop->cop_warnings &&                                    \
175           ( PL_curcop->cop_warnings == WARN_ALL ||                      \
176             SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x)  ) ) )
177
178 #define ckWARN2(x,y)                                                    \
179         ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) &&  \
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) ) ) ) 
184
185 #endif
186
187 #define WARN_NONE               NULL
188 #define WARN_ALL                (&PL_sv_yes)
189
190 EOM
191
192
193 $index = 0 ;
194 @{ $list{"all"} } = walk ($tree) ;
195
196 $index *= 2 ;
197 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
198
199 my $k ;
200 foreach $k (sort { $a <=> $b } keys %Value) {
201     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
202 }
203 print WARN "\n" ;
204
205 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
206 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
207 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
208 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
209
210 print WARN <<'EOM';
211
212 /* end of file warning.h */
213
214 EOM
215
216 close WARN ;
217
218 while (<DATA>) {
219     last if /^KEYWORDS$/ ;
220     print PM $_ ;
221 }
222
223 $list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
224 print PM "%Bits = (\n" ;
225 foreach $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
236 print PM "  );\n\n" ;
237
238 print PM "%DeadBits = (\n" ;
239 foreach $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
250 print PM "  );\n\n" ;
251 while (<DATA>) {
252     print PM $_ ;
253 }
254
255 close PM ;
256
257 __END__
258
259 # This file was created by warning.pl
260 # Any changes made here will be lost.
261 #
262
263 package warning;
264
265 =head1 NAME
266
267 warning - Perl pragma to control optional warnings
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
281 If 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
283 casual programming.)  Currently, there are three possible things to be
284 strict about:  
285
286 =over 6
287
288 =item C<warning deprecated>
289
290 This generates a runtime error if you use deprecated 
291
292     use warning 'deprecated';
293
294 =back
295
296 See L<perlmod/Pragmatic Modules>.
297
298
299 =cut
300
301 use Carp ;
302
303 KEYWORDS
304
305 sub 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
323 sub import {
324     shift;
325     $^B |= bits(@_ ? @_ : 'all') ;
326 }
327
328 sub unimport {
329     shift;
330     $^B &= ~ bits(@_ ? @_ : 'all') ;
331 }
332
333
334 sub 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
346 sub bitmask
347 {
348     return $^B ;
349 }
350
351 sub enabled
352 {
353     my $string = shift ;
354
355     return 1
356         if $bits{$string} && $^B & $bits{$string} ;
357    
358     return 0 ; 
359 }
360
361 1;