Update Changes.
[p5sagit/p5-mst-13.2.git] / warnings.pl
CommitLineData
599cee73 1#!/usr/bin/perl
2
73f0cc2d 3BEGIN {
4 push @INC, './lib';
5}
599cee73 6use strict ;
7
8sub DEFAULT_ON () { 1 }
9sub DEFAULT_OFF () { 2 }
10
11my $tree = {
d3a7d8c7 12
13'all' => {
e476b1b5 14 'io' => { 'pipe' => DEFAULT_OFF,
599cee73 15 'unopened' => DEFAULT_OFF,
16 'closed' => DEFAULT_OFF,
17 'newline' => DEFAULT_OFF,
18 'exec' => DEFAULT_OFF,
599cee73 19 },
e476b1b5 20 'syntax' => { 'ambiguous' => DEFAULT_OFF,
599cee73 21 'semicolon' => DEFAULT_OFF,
e476b1b5 22 'precedence' => DEFAULT_OFF,
4673fc70 23 'bareword' => DEFAULT_OFF,
599cee73 24 'reserved' => DEFAULT_OFF,
627300f0 25 'digit' => DEFAULT_OFF,
599cee73 26 'parenthesis' => DEFAULT_OFF,
27 'deprecated' => DEFAULT_OFF,
28 'printf' => DEFAULT_OFF,
e476b1b5 29 'prototype' => DEFAULT_OFF,
30 'qw' => DEFAULT_OFF,
599cee73 31 },
e476b1b5 32 'severe' => { 'inplace' => DEFAULT_ON,
0453d815 33 'internal' => DEFAULT_ON,
34 'debugging' => DEFAULT_ON,
e476b1b5 35 'malloc' => DEFAULT_ON,
0453d815 36 },
e476b1b5 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,
0453d815 60 #'default' => DEFAULT_ON,
d3a7d8c7 61 }
62} ;
599cee73 63
64
65###########################################################################
66sub tab {
67 my($l, $t) = @_;
68 $t .= "\t" x ($l - (length($t) + 1) / 8);
69 $t;
70}
71
72###########################################################################
73
74my %list ;
75my %Value ;
d3a7d8c7 76my $index ;
599cee73 77
78sub walk
79{
80 my $tre = shift ;
81 my @list = () ;
82 my ($k, $v) ;
83
95dfd3ab 84 foreach $k (sort keys %$tre) {
85 $v = $tre->{$k};
599cee73 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 ;
599cee73 95}
96
97###########################################################################
98
99sub 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###########################################################################
e476b1b5 118sub 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###########################################################################
599cee73 144
145sub 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
e476b1b5 165if (@ARGV && $ARGV[0] eq "tree")
166{
d3a7d8c7 167 #print " all -+\n" ;
e476b1b5 168 printTree($tree, " ", 4) ;
169 exit ;
170}
599cee73 171
4438c4b7 172#unlink "warnings.h";
173#unlink "lib/warnings.pm";
174open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
175open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
599cee73 176
177print WARN <<'EOM' ;
178/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 179 This file is built by warnings.pl
599cee73 180 Any changes made here will be lost!
181*/
182
183
0453d815 184#define Off(x) ((x) / 8)
185#define Bit(x) (1 << ((x) % 8))
599cee73 186#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
187
0453d815 188
599cee73 189#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 190#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73 191#define G_WARN_ALL_ON 2 /* -W flag */
192#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 193#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73 194#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
195
d3a7d8c7 196#define pWARN_STD Nullsv
197#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
198#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73 199
d3a7d8c7 200#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
201 (x) == pWARN_NONE)
599cee73 202EOM
203
d3a7d8c7 204my $offset = 0 ;
205
206$index = $offset ;
207#@{ $list{"all"} } = walk ($tree) ;
208walk ($tree) ;
599cee73 209
599cee73 210
211$index *= 2 ;
212my $warn_size = int($index / 8) + ($index % 8 != 0) ;
213
214my $k ;
215foreach $k (sort { $a <=> $b } keys %Value) {
216 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
217}
218print WARN "\n" ;
219
220print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
221#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
222print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
223print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
224
225print WARN <<'EOM';
226
d5a71f30 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
4438c4b7 262/* end of file warnings.h */
599cee73 263
264EOM
265
266close WARN ;
267
268while (<DATA>) {
269 last if /^KEYWORDS$/ ;
270 print PM $_ ;
271}
272
d3a7d8c7 273#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
274
275#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
276
277print PM "%Offsets = (\n" ;
278foreach 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
284print PM " );\n\n" ;
285
599cee73 286print PM "%Bits = (\n" ;
287foreach $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
298print PM " );\n\n" ;
299
300print PM "%DeadBits = (\n" ;
301foreach $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
312print PM " );\n\n" ;
d3a7d8c7 313print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
314print PM '$LAST_BIT = ' . "$index ;\n" ;
315print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73 316while (<DATA>) {
317 print PM $_ ;
318}
319
320close PM ;
321
322__END__
323
4438c4b7 324# This file was created by warnings.pl
599cee73 325# Any changes made here will be lost.
326#
327
4438c4b7 328package warnings;
599cee73 329
330=head1 NAME
331
4438c4b7 332warnings - Perl pragma to control optional warnings
599cee73 333
334=head1 SYNOPSIS
335
4438c4b7 336 use warnings;
337 no warnings;
599cee73 338
4438c4b7 339 use warnings "all";
340 no warnings "all";
599cee73 341
d3a7d8c7 342 use warnings::register;
343 if (warnings::enabled()) {
344 warnings::warn("some warning");
345 }
346
347 if (warnings::enabled("void")) {
e476b1b5 348 warnings::warn("void", "some warning");
349 }
350
599cee73 351=head1 DESCRIPTION
352
0453d815 353If no import list is supplied, all possible warnings are either enabled
354or disabled.
599cee73 355
d3a7d8c7 356A number of functions are provided to assist module authors.
e476b1b5 357
358=over 4
359
d3a7d8c7 360=item use warnings::register
361
362Creates a new warnings category which has the same name as the module
363where the call to the pragma is used.
364
365=item warnings::enabled([$category])
e476b1b5 366
d3a7d8c7 367Returns TRUE if the warnings category C<$category> is enabled in the
368calling module. Otherwise returns FALSE.
e476b1b5 369
d3a7d8c7 370If the parameter, C<$category>, isn't supplied, the current package name
371will be used.
e476b1b5 372
d3a7d8c7 373=item warnings::warn([$category,] $message)
599cee73 374
e476b1b5 375If the calling module has I<not> set C<$category> to "FATAL", print
376C<$message> to STDERR.
377If the calling module has set C<$category> to "FATAL", print C<$message>
378STDERR then die.
379
d3a7d8c7 380If the parameter, C<$category>, isn't supplied, the current package name
381will be used.
382
e476b1b5 383=back
384
749f83fa 385See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73 386
387=cut
388
389use Carp ;
390
391KEYWORDS
392
d3a7d8c7 393$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
394
599cee73 395sub bits {
396 my $mask ;
397 my $catmask ;
398 my $fatal = 0 ;
399 foreach my $word (@_) {
327afb7f 400 if ($word eq 'FATAL') {
401 $fatal = 1;
402 }
d3a7d8c7 403 elsif ($catmask = $Bits{$word}) {
404 $mask |= $catmask ;
405 $mask |= $DeadBits{$word} if $fatal ;
599cee73 406 }
d3a7d8c7 407 else
408 { croak("unknown warnings category '$word'")}
599cee73 409 }
410
411 return $mask ;
412}
413
414sub import {
415 shift;
6a818117 416 ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
599cee73 417}
418
419sub unimport {
420 shift;
d3a7d8c7 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) ;
599cee73 427}
428
429sub enabled
430{
d3a7d8c7 431 croak("Usage: warnings::enabled([category])")
432 unless @_ == 1 || @_ == 0 ;
433 local $Carp::CarpLevel = 1 ;
434 my $category ;
435 my $offset ;
e476b1b5 436 my $callers_bitmask = (caller(1))[9] ;
e476b1b5 437 return 0 unless defined $callers_bitmask ;
d3a7d8c7 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) ;
599cee73 456}
457
d3a7d8c7 458
e476b1b5 459sub warn
460{
d3a7d8c7 461 croak("Usage: warnings::warn([category,] 'message')")
462 unless @_ == 2 || @_ == 1 ;
e476b1b5 463 local $Carp::CarpLevel = 1 ;
d3a7d8c7 464 my $category ;
465 my $offset ;
e476b1b5 466 my $callers_bitmask = (caller(1))[9] ;
d3a7d8c7 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 ;
e476b1b5 482 croak($message)
d3a7d8c7 483 if vec($callers_bitmask, $offset+1, 1) ||
484 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5 485 carp($message) ;
486}
487
599cee73 4881;