nit from Spider Boardman
[p5sagit/p5-mst-13.2.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         'io'            => {    'pipe'          => DEFAULT_OFF,
13                                 'unopened'      => DEFAULT_OFF,
14                                 'closed'        => DEFAULT_OFF,
15                                 'newline'       => DEFAULT_OFF,
16                                 'exec'          => DEFAULT_OFF,
17                            },
18         'syntax'        => {    'ambiguous'     => DEFAULT_OFF,
19                                 'semicolon'     => DEFAULT_OFF,
20                                 'precedence'    => DEFAULT_OFF,
21                                 'bareword'      => DEFAULT_OFF,
22                                 'reserved'      => DEFAULT_OFF,
23                                 'digit'         => DEFAULT_OFF,
24                                 'parenthesis'   => DEFAULT_OFF,
25                                 'deprecated'    => DEFAULT_OFF,
26                                 'printf'        => DEFAULT_OFF,
27                                 'prototype'     => DEFAULT_OFF,
28                                 'qw'            => DEFAULT_OFF,
29                            },
30         'severe'        => {    'inplace'       => DEFAULT_ON,
31                                 'internal'      => DEFAULT_ON,
32                                 'debugging'     => DEFAULT_ON,
33                                 'malloc'        => DEFAULT_ON,
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         '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,
58          #'default'     => DEFAULT_ON,
59         } ;
60
61
62 ###########################################################################
63 sub tab {
64     my($l, $t) = @_;
65     $t .= "\t" x ($l - (length($t) + 1) / 8);
66     $t;
67 }
68
69 ###########################################################################
70
71 my %list ;
72 my %Value ;
73 my $index = 0 ;
74
75 sub walk
76 {
77     my $tre = shift ;
78     my @list = () ;
79     my ($k, $v) ;
80
81     foreach $k (sort keys %$tre) {
82         $v = $tre->{$k};
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 ;
92 }
93
94 ###########################################################################
95
96 sub 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 ###########################################################################
115 sub 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 ###########################################################################
141
142 sub 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
162 if (@ARGV && $ARGV[0] eq "tree")
163 {
164     print "  all -+\n" ;
165     printTree($tree, "   ", 4) ;
166     exit ;
167 }
168
169 #unlink "warnings.h";
170 #unlink "lib/warnings.pm";
171 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
172 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
173
174 print WARN <<'EOM' ;
175 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
176    This file is built by warnings.pl
177    Any changes made here will be lost!
178 */
179
180
181 #define Off(x)                  ((x) / 8)
182 #define Bit(x)                  (1 << ((x) % 8))
183 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
184
185
186 #define G_WARN_OFF              0       /* $^W == 0 */
187 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
188 #define G_WARN_ALL_ON           2       /* -W flag */
189 #define G_WARN_ALL_OFF          4       /* -X flag */
190 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
191 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
192
193 #define WARN_STD                Nullsv
194 #define WARN_ALL                (Nullsv+1)      /* use warnings 'all' */
195 #define WARN_NONE               (Nullsv+2)      /* no  warnings 'all' */
196
197 #define specialWARN(x)          ((x) == WARN_STD || (x) == WARN_ALL ||  \
198                                  (x) == WARN_NONE)
199
200 #define ckDEAD(x)                                                       \
201            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
202             IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
203
204 #define ckWARN(x)                                                       \
205         ( (PL_curcop->cop_warnings != WARN_STD &&                       \
206            PL_curcop->cop_warnings != WARN_NONE &&                      \
207               (PL_curcop->cop_warnings == WARN_ALL ||                   \
208                IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )           \
209           || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
210
211 #define ckWARN2(x,y)                                                    \
212           ( (PL_curcop->cop_warnings != WARN_STD  &&                    \
213              PL_curcop->cop_warnings != WARN_NONE &&                    \
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) ) )          \
217             ||  (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
218
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) ) )
224
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) ) ) )
231
232
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)))
237
238 EOM
239
240
241 $index = 0 ;
242 @{ $list{"all"} } = walk ($tree) ;
243
244 $index *= 2 ;
245 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
246
247 my $k ;
248 foreach $k (sort { $a <=> $b } keys %Value) {
249     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
250 }
251 print WARN "\n" ;
252
253 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
254 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
255 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
256 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
257
258 print WARN <<'EOM';
259
260 /* end of file warnings.h */
261
262 EOM
263
264 close WARN ;
265
266 while (<DATA>) {
267     last if /^KEYWORDS$/ ;
268     print PM $_ ;
269 }
270
271 $list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
272 print PM "%Bits = (\n" ;
273 foreach $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
284 print PM "  );\n\n" ;
285
286 print PM "%DeadBits = (\n" ;
287 foreach $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
298 print PM "  );\n\n" ;
299 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
300 while (<DATA>) {
301     print PM $_ ;
302 }
303
304 close PM ;
305
306 __END__
307
308 # This file was created by warnings.pl
309 # Any changes made here will be lost.
310 #
311
312 package warnings;
313
314 =head1 NAME
315
316 warnings - Perl pragma to control optional warnings
317
318 =head1 SYNOPSIS
319
320     use warnings;
321     no warnings;
322
323     use warnings "all";
324     no warnings "all";
325
326     if (warnings::enabled("void") {
327         warnings::warn("void", "some warning");
328     }
329
330 =head1 DESCRIPTION
331
332 If no import list is supplied, all possible warnings are either enabled
333 or disabled.
334
335 Two functions are provided to assist module authors.
336
337 =over 4
338
339 =item warnings::enabled($category)
340
341 Returns TRUE if the warnings category in C<$category> is enabled in the
342 calling module. Otherwise returns FALSE.
343
344
345 =item warnings::warn($category, $message)
346
347 If the calling module has I<not> set C<$category> to "FATAL", print
348 C<$message> to STDERR.
349 If the calling module has set C<$category> to "FATAL", print C<$message>
350 STDERR then die.
351
352 =back
353
354 See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
355
356 =cut
357
358 use Carp ;
359
360 KEYWORDS
361
362 sub bits {
363     my $mask ;
364     my $catmask ;
365     my $fatal = 0 ;
366     foreach my $word (@_) {
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             }
375         }
376     }
377
378     return $mask ;
379 }
380
381 sub import {
382     shift;
383     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
384 }
385
386 sub unimport {
387     shift;
388     ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
389 }
390
391 sub enabled
392 {
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 ;
403     return 1
404         if ($callers_bitmask & $Bits{$category}) ne $NONE ;
405    
406     return 0 ; 
407 }
408
409 sub 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
423 1;