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
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
73f0cc2d
GS
3BEGIN {
4 push @INC, './lib';
5}
599cee73
PM
6use strict ;
7
8sub DEFAULT_ON () { 1 }
9sub DEFAULT_OFF () { 2 }
10
11my $tree = {
d3a7d8c7
GS
12
13'all' => {
e476b1b5 14 'io' => { 'pipe' => DEFAULT_OFF,
599cee73
PM
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
PM
26 'parenthesis' => DEFAULT_OFF,
27 'deprecated' => DEFAULT_OFF,
28 'printf' => DEFAULT_OFF,
e476b1b5
GS
29 'prototype' => DEFAULT_OFF,
30 'qw' => DEFAULT_OFF,
599cee73 31 },
e476b1b5 32 'severe' => { 'inplace' => DEFAULT_ON,
0453d815
PM
33 'internal' => DEFAULT_ON,
34 'debugging' => DEFAULT_ON,
e476b1b5 35 'malloc' => DEFAULT_ON,
0453d815 36 },
e476b1b5
GS
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
GS
61 }
62} ;
599cee73
PM
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
PM
77
78sub walk
79{
80 my $tre = shift ;
81 my @list = () ;
82 my ($k, $v) ;
83
95dfd3ab
GS
84 foreach $k (sort keys %$tre) {
85 $v = $tre->{$k};
599cee73
PM
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
PM
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
GS
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
PM
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
GS
165if (@ARGV && $ARGV[0] eq "tree")
166{
d3a7d8c7 167 #print " all -+\n" ;
e476b1b5
GS
168 printTree($tree, " ", 4) ;
169 exit ;
170}
599cee73 171
4438c4b7
JH
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
PM
176
177print WARN <<'EOM' ;
178/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 179 This file is built by warnings.pl
599cee73
PM
180 Any changes made here will be lost!
181*/
182
183
0453d815
PM
184#define Off(x) ((x) / 8)
185#define Bit(x) (1 << ((x) % 8))
599cee73
PM
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
PM
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
PM
194#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
195
d3a7d8c7
GS
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
GS
200#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
201 (x) == pWARN_NONE)
599cee73
PM
202
203#define ckDEAD(x) \
0453d815 204 ( ! specialWARN(PL_curcop->cop_warnings) && \
e24b16f9 205 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
599cee73
PM
206
207#define ckWARN(x) \
d3a7d8c7
GS
208 ( (PL_curcop->cop_warnings != pWARN_STD && \
209 PL_curcop->cop_warnings != pWARN_NONE && \
210 (PL_curcop->cop_warnings == pWARN_ALL || \
e24b16f9 211 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \
d3a7d8c7 212 || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
599cee73
PM
213
214#define ckWARN2(x,y) \
d3a7d8c7
GS
215 ( (PL_curcop->cop_warnings != pWARN_STD && \
216 PL_curcop->cop_warnings != pWARN_NONE && \
217 (PL_curcop->cop_warnings == pWARN_ALL || \
e24b16f9
GS
218 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
219 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \
d3a7d8c7 220 || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
599cee73 221
0453d815 222#define ckWARN_d(x) \
d3a7d8c7
GS
223 (PL_curcop->cop_warnings == pWARN_STD || \
224 PL_curcop->cop_warnings == pWARN_ALL || \
225 (PL_curcop->cop_warnings != pWARN_NONE && \
0453d815 226 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
599cee73 227
0453d815 228#define ckWARN2_d(x,y) \
d3a7d8c7
GS
229 (PL_curcop->cop_warnings == pWARN_STD || \
230 PL_curcop->cop_warnings == pWARN_ALL || \
231 (PL_curcop->cop_warnings != pWARN_NONE && \
0453d815
PM
232 (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
233 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
599cee73 234
599cee73 235
d3a7d8c7
GS
236#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
237#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
0453d815
PM
238#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
239#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
599cee73
PM
240
241EOM
242
d3a7d8c7
GS
243my $offset = 0 ;
244
245$index = $offset ;
246#@{ $list{"all"} } = walk ($tree) ;
247walk ($tree) ;
599cee73 248
599cee73
PM
249
250$index *= 2 ;
251my $warn_size = int($index / 8) + ($index % 8 != 0) ;
252
253my $k ;
254foreach $k (sort { $a <=> $b } keys %Value) {
255 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
256}
257print WARN "\n" ;
258
259print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
260#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
261print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
262print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
263
264print WARN <<'EOM';
265
4438c4b7 266/* end of file warnings.h */
599cee73
PM
267
268EOM
269
270close WARN ;
271
272while (<DATA>) {
273 last if /^KEYWORDS$/ ;
274 print PM $_ ;
275}
276
d3a7d8c7
GS
277#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
278
279#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
280
281print PM "%Offsets = (\n" ;
282foreach 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
288print PM " );\n\n" ;
289
599cee73
PM
290print PM "%Bits = (\n" ;
291foreach $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
302print PM " );\n\n" ;
303
304print PM "%DeadBits = (\n" ;
305foreach $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
316print PM " );\n\n" ;
d3a7d8c7
GS
317print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
318print PM '$LAST_BIT = ' . "$index ;\n" ;
319print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73
PM
320while (<DATA>) {
321 print PM $_ ;
322}
323
324close PM ;
325
326__END__
327
4438c4b7 328# This file was created by warnings.pl
599cee73
PM
329# Any changes made here will be lost.
330#
331
4438c4b7 332package warnings;
599cee73
PM
333
334=head1 NAME
335
4438c4b7 336warnings - Perl pragma to control optional warnings
599cee73
PM
337
338=head1 SYNOPSIS
339
4438c4b7
JH
340 use warnings;
341 no warnings;
599cee73 342
4438c4b7
JH
343 use warnings "all";
344 no warnings "all";
599cee73 345
d3a7d8c7
GS
346 use warnings::register;
347 if (warnings::enabled()) {
348 warnings::warn("some warning");
349 }
350
351 if (warnings::enabled("void")) {
e476b1b5
GS
352 warnings::warn("void", "some warning");
353 }
354
599cee73
PM
355=head1 DESCRIPTION
356
0453d815
PM
357If no import list is supplied, all possible warnings are either enabled
358or disabled.
599cee73 359
d3a7d8c7 360A number of functions are provided to assist module authors.
e476b1b5
GS
361
362=over 4
363
d3a7d8c7
GS
364=item use warnings::register
365
366Creates a new warnings category which has the same name as the module
367where the call to the pragma is used.
368
369=item warnings::enabled([$category])
e476b1b5 370
d3a7d8c7
GS
371Returns TRUE if the warnings category C<$category> is enabled in the
372calling module. Otherwise returns FALSE.
e476b1b5 373
d3a7d8c7
GS
374If the parameter, C<$category>, isn't supplied, the current package name
375will be used.
e476b1b5 376
d3a7d8c7 377=item warnings::warn([$category,] $message)
599cee73 378
e476b1b5
GS
379If the calling module has I<not> set C<$category> to "FATAL", print
380C<$message> to STDERR.
381If the calling module has set C<$category> to "FATAL", print C<$message>
382STDERR then die.
383
d3a7d8c7
GS
384If the parameter, C<$category>, isn't supplied, the current package name
385will be used.
386
e476b1b5
GS
387=back
388
389See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
390
391=cut
392
393use Carp ;
394
395KEYWORDS
396
d3a7d8c7
GS
397$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
398
599cee73
PM
399sub bits {
400 my $mask ;
401 my $catmask ;
402 my $fatal = 0 ;
403 foreach my $word (@_) {
327afb7f
GS
404 if ($word eq 'FATAL') {
405 $fatal = 1;
406 }
d3a7d8c7
GS
407 elsif ($catmask = $Bits{$word}) {
408 $mask |= $catmask ;
409 $mask |= $DeadBits{$word} if $fatal ;
599cee73 410 }
d3a7d8c7
GS
411 else
412 { croak("unknown warnings category '$word'")}
599cee73
PM
413 }
414
415 return $mask ;
416}
417
418sub import {
419 shift;
6a818117 420 ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
599cee73
PM
421}
422
423sub unimport {
424 shift;
d3a7d8c7
GS
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) ;
599cee73
PM
431}
432
433sub enabled
434{
d3a7d8c7
GS
435 croak("Usage: warnings::enabled([category])")
436 unless @_ == 1 || @_ == 0 ;
437 local $Carp::CarpLevel = 1 ;
438 my $category ;
439 my $offset ;
e476b1b5 440 my $callers_bitmask = (caller(1))[9] ;
e476b1b5 441 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
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) ;
599cee73
PM
460}
461
d3a7d8c7 462
e476b1b5
GS
463sub warn
464{
d3a7d8c7
GS
465 croak("Usage: warnings::warn([category,] 'message')")
466 unless @_ == 2 || @_ == 1 ;
e476b1b5 467 local $Carp::CarpLevel = 1 ;
d3a7d8c7
GS
468 my $category ;
469 my $offset ;
e476b1b5 470 my $callers_bitmask = (caller(1))[9] ;
d3a7d8c7
GS
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 ;
e476b1b5 486 croak($message)
d3a7d8c7
GS
487 if vec($callers_bitmask, $offset+1, 1) ||
488 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
489 carp($message) ;
490}
491
599cee73 4921;