This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Typo in pp_complement().
[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
202EOM
203
d3a7d8c7
GS
204my $offset = 0 ;
205
206$index = $offset ;
207#@{ $list{"all"} } = walk ($tree) ;
208walk ($tree) ;
599cee73 209
599cee73
PM
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
GS
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
PM
263
264EOM
265
266close WARN ;
267
268while (<DATA>) {
269 last if /^KEYWORDS$/ ;
270 print PM $_ ;
271}
272
d3a7d8c7
GS
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
PM
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
GS
313print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
314print PM '$LAST_BIT = ' . "$index ;\n" ;
315print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73
PM
316while (<DATA>) {
317 print PM $_ ;
318}
319
320close PM ;
321
322__END__
323
4438c4b7 324# This file was created by warnings.pl
599cee73
PM
325# Any changes made here will be lost.
326#
327
4438c4b7 328package warnings;
599cee73
PM
329
330=head1 NAME
331
4438c4b7 332warnings - Perl pragma to control optional warnings
599cee73
PM
333
334=head1 SYNOPSIS
335
4438c4b7
JH
336 use warnings;
337 no warnings;
599cee73 338
4438c4b7
JH
339 use warnings "all";
340 no warnings "all";
599cee73 341
d3a7d8c7
GS
342 use warnings::register;
343 if (warnings::enabled()) {
344 warnings::warn("some warning");
345 }
346
347 if (warnings::enabled("void")) {
e476b1b5
GS
348 warnings::warn("void", "some warning");
349 }
350
599cee73
PM
351=head1 DESCRIPTION
352
0453d815
PM
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
GS
357
358=over 4
359
d3a7d8c7
GS
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
GS
367Returns TRUE if the warnings category C<$category> is enabled in the
368calling module. Otherwise returns FALSE.
e476b1b5 369
d3a7d8c7
GS
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
GS
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
GS
380If the parameter, C<$category>, isn't supplied, the current package name
381will be used.
382
e476b1b5
GS
383=back
384
749f83fa 385See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
386
387=cut
388
389use Carp ;
390
391KEYWORDS
392
d3a7d8c7
GS
393$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
394
599cee73
PM
395sub bits {
396 my $mask ;
397 my $catmask ;
398 my $fatal = 0 ;
399 foreach my $word (@_) {
327afb7f
GS
400 if ($word eq 'FATAL') {
401 $fatal = 1;
402 }
d3a7d8c7
GS
403 elsif ($catmask = $Bits{$word}) {
404 $mask |= $catmask ;
405 $mask |= $DeadBits{$word} if $fatal ;
599cee73 406 }
d3a7d8c7
GS
407 else
408 { croak("unknown warnings category '$word'")}
599cee73
PM
409 }
410
411 return $mask ;
412}
413
414sub import {
415 shift;
6a818117 416 ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
599cee73
PM
417}
418
419sub unimport {
420 shift;
d3a7d8c7
GS
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
PM
427}
428
429sub enabled
430{
d3a7d8c7
GS
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
GS
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
PM
456}
457
d3a7d8c7 458
e476b1b5
GS
459sub warn
460{
d3a7d8c7
GS
461 croak("Usage: warnings::warn([category,] 'message')")
462 unless @_ == 2 || @_ == 1 ;
e476b1b5 463 local $Carp::CarpLevel = 1 ;
d3a7d8c7
GS
464 my $category ;
465 my $offset ;
e476b1b5 466 my $callers_bitmask = (caller(1))[9] ;
d3a7d8c7
GS
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
GS
483 if vec($callers_bitmask, $offset+1, 1) ||
484 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
485 carp($message) ;
486}
487
599cee73 4881;