This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fixes for bugs in C<use warnings qw(FATAL all)> (from Paul Marquess)
[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 EOM
203
204 my $offset = 0 ;
205
206 $index = $offset ;
207 #@{ $list{"all"} } = walk ($tree) ;
208 walk ($tree) ;
209
210
211 $index *= 2 ;
212 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
213
214 my $k ;
215 foreach $k (sort { $a <=> $b } keys %Value) {
216     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
217 }
218 print WARN "\n" ;
219
220 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
221 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
222 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
223 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
224
225 print WARN <<'EOM';
226
227 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
228 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
229 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
230 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
231 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
232
233 #define ckDEAD(x)                                                       \
234            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
235             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
236               isWARNf_on(PL_curcop->cop_warnings, x)))
237
238 #define ckWARN(x)                                                       \
239         ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&     \
240               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
241                isWARN_on(PL_curcop->cop_warnings, x) ) )                \
242           || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
243
244 #define ckWARN2(x,y)                                                    \
245           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
246               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
247                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
248                 isWARN_on(PL_curcop->cop_warnings, y) ) )               \
249             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
250
251 #define ckWARN_d(x)                                                     \
252           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
253              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
254               isWARN_on(PL_curcop->cop_warnings, x) ) )
255
256 #define ckWARN2_d(x,y)                                                  \
257           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
258              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
259                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
260                  isWARN_on(PL_curcop->cop_warnings, y) ) ) )
261
262 /* end of file warnings.h */
263
264 EOM
265
266 close WARN ;
267
268 while (<DATA>) {
269     last if /^KEYWORDS$/ ;
270     print PM $_ ;
271 }
272
273 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
274
275 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
276
277 print PM "%Offsets = (\n" ;
278 foreach my $k (sort { $a <=> $b } keys %Value) {
279     my $v = lc $Value{$k} ;
280     $k *= 2 ;
281     print PM tab(4, "    '$v'"), "=> $k,\n" ;
282 }
283
284 print PM "  );\n\n" ;
285
286 print PM "%Bits = (\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 , @list), 
295                 '", # [', mkRange(@list), "]\n" ;
296 }
297
298 print PM "  );\n\n" ;
299
300 print PM "%DeadBits = (\n" ;
301 foreach $k (sort keys  %list) {
302
303     my $v = $list{$k} ;
304     my @list = sort { $a <=> $b } @$v ;
305
306     print PM tab(4, "    '$k'"), '=> "', 
307                 # mkHex($warn_size, @list), 
308                 mkHex($warn_size, map $_ * 2 + 1 , @list), 
309                 '", # [', mkRange(@list), "]\n" ;
310 }
311
312 print PM "  );\n\n" ;
313 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
314 print PM '$LAST_BIT = ' . "$index ;\n" ;
315 print PM '$BYTES    = ' . "$warn_size ;\n" ;
316 while (<DATA>) {
317     print PM $_ ;
318 }
319
320 close PM ;
321
322 __END__
323
324 # This file was created by warnings.pl
325 # Any changes made here will be lost.
326 #
327
328 package warnings;
329
330 =head1 NAME
331
332 warnings - Perl pragma to control optional warnings
333
334 =head1 SYNOPSIS
335
336     use warnings;
337     no warnings;
338
339     use warnings "all";
340     no warnings "all";
341
342     use warnings::register;
343     if (warnings::enabled()) {
344         warnings::warn("some warning");
345     }
346
347     if (warnings::enabled("void")) {
348         warnings::warn("void", "some warning");
349     }
350
351 =head1 DESCRIPTION
352
353 If no import list is supplied, all possible warnings are either enabled
354 or disabled.
355
356 A number of functions are provided to assist module authors. 
357
358 =over 4
359
360 =item use warnings::register
361
362 Creates a new warnings category which has the same name as the module
363 where the call to the pragma is used.
364
365 =item warnings::enabled([$category])
366
367 Returns TRUE if the warnings category C<$category> is enabled in the
368 calling module.  Otherwise returns FALSE.
369
370 If the parameter, C<$category>, isn't supplied, the current package name
371 will be used.
372
373 =item warnings::warn([$category,] $message)
374
375 If the calling module has I<not> set C<$category> to "FATAL", print
376 C<$message> to STDERR.
377 If the calling module has set C<$category> to "FATAL", print C<$message>
378 STDERR then die.
379
380 If the parameter, C<$category>, isn't supplied, the current package name
381 will be used.
382
383 =back
384
385 See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
386
387 =cut
388
389 use Carp ;
390
391 KEYWORDS
392
393 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
394
395 sub bits {
396     my $mask ;
397     my $catmask ;
398     my $fatal = 0 ;
399     foreach my $word (@_) {
400         if  ($word eq 'FATAL') {
401             $fatal = 1;
402         }
403         elsif ($catmask = $Bits{$word}) {
404             $mask |= $catmask ;
405             $mask |= $DeadBits{$word} if $fatal ;
406         }
407         else
408           { croak("unknown warnings category '$word'")}  
409     }
410
411     return $mask ;
412 }
413
414 sub import {
415     shift;
416     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
417 }
418
419 sub unimport {
420     shift;
421     my $mask = ${^WARNING_BITS} ;
422     if (vec($mask, $Offsets{'all'}, 1)) {
423         $mask = $Bits{'all'} ;
424         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
425     }
426     ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
427 }
428
429 sub enabled
430 {
431     croak("Usage: warnings::enabled([category])")
432         unless @_ == 1 || @_ == 0 ;
433     local $Carp::CarpLevel = 1 ;
434     my $category ;
435     my $offset ;
436     my $callers_bitmask = (caller(1))[9] ; 
437     return 0 unless defined $callers_bitmask ;
438
439
440     if (@_) {
441         # check the category supplied.
442         $category = shift ;
443         $offset = $Offsets{$category};
444         croak("unknown warnings category '$category'")
445             unless defined $offset;
446     }
447     else {
448         $category = (caller(0))[0] ; 
449         $offset = $Offsets{$category};
450         croak("package '$category' not registered for warnings")
451             unless defined $offset ;
452     }
453
454     return vec($callers_bitmask, $offset, 1) ||
455            vec($callers_bitmask, $Offsets{'all'}, 1) ;
456 }
457
458
459 sub warn
460 {
461     croak("Usage: warnings::warn([category,] 'message')")
462         unless @_ == 2 || @_ == 1 ;
463     local $Carp::CarpLevel = 1 ;
464     my $category ;
465     my $offset ;
466     my $callers_bitmask = (caller(1))[9] ; 
467
468     if (@_ == 2) {
469         $category = shift ;
470         $offset = $Offsets{$category};
471         croak("unknown warnings category '$category'")
472             unless defined $offset ;
473     }
474     else {
475         $category = (caller(0))[0] ; 
476         $offset = $Offsets{$category};
477         croak("package '$category' not registered for warnings")
478             unless defined $offset ;
479     }
480
481     my $message = shift ;
482     croak($message) 
483         if vec($callers_bitmask, $offset+1, 1) ||
484            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
485     carp($message) ;
486 }
487
488 1;