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