This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Changes.
[perl5.git] / warnings.pl
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
0ca4541c
NIS
3
4$VERSION = '1.00';
b75c8c73 5
73f0cc2d
GS
6BEGIN {
7 push @INC, './lib';
8}
599cee73
PM
9use strict ;
10
11sub DEFAULT_ON () { 1 }
12sub DEFAULT_OFF () { 2 }
13
14my $tree = {
d3a7d8c7
GS
15
16'all' => {
e476b1b5 17 'io' => { 'pipe' => DEFAULT_OFF,
599cee73
PM
18 'unopened' => DEFAULT_OFF,
19 'closed' => DEFAULT_OFF,
20 'newline' => DEFAULT_OFF,
21 'exec' => DEFAULT_OFF,
599cee73 22 },
e476b1b5 23 'syntax' => { 'ambiguous' => DEFAULT_OFF,
599cee73 24 'semicolon' => DEFAULT_OFF,
e476b1b5 25 'precedence' => DEFAULT_OFF,
4673fc70 26 'bareword' => DEFAULT_OFF,
599cee73 27 'reserved' => DEFAULT_OFF,
627300f0 28 'digit' => DEFAULT_OFF,
599cee73
PM
29 'parenthesis' => DEFAULT_OFF,
30 'deprecated' => DEFAULT_OFF,
31 'printf' => DEFAULT_OFF,
e476b1b5
GS
32 'prototype' => DEFAULT_OFF,
33 'qw' => DEFAULT_OFF,
599cee73 34 },
e476b1b5 35 'severe' => { 'inplace' => DEFAULT_ON,
0453d815
PM
36 'internal' => DEFAULT_ON,
37 'debugging' => DEFAULT_ON,
e476b1b5 38 'malloc' => DEFAULT_ON,
0453d815 39 },
e476b1b5
GS
40 'void' => DEFAULT_OFF,
41 'recursion' => DEFAULT_OFF,
42 'redefine' => DEFAULT_OFF,
43 'numeric' => DEFAULT_OFF,
44 'uninitialized' => DEFAULT_OFF,
45 'once' => DEFAULT_OFF,
46 'misc' => DEFAULT_OFF,
47 'regexp' => DEFAULT_OFF,
48 'glob' => DEFAULT_OFF,
49 'y2k' => DEFAULT_OFF,
e476b1b5
GS
50 'untie' => DEFAULT_OFF,
51 'substr' => DEFAULT_OFF,
52 'taint' => DEFAULT_OFF,
53 'signal' => DEFAULT_OFF,
54 'closure' => DEFAULT_OFF,
55 'overflow' => DEFAULT_OFF,
56 'portable' => DEFAULT_OFF,
57 'utf8' => DEFAULT_OFF,
58 'exiting' => DEFAULT_OFF,
59 'pack' => DEFAULT_OFF,
60 'unpack' => DEFAULT_OFF,
0453d815 61 #'default' => DEFAULT_ON,
d3a7d8c7
GS
62 }
63} ;
599cee73
PM
64
65
66###########################################################################
67sub tab {
68 my($l, $t) = @_;
69 $t .= "\t" x ($l - (length($t) + 1) / 8);
70 $t;
71}
72
73###########################################################################
74
75my %list ;
76my %Value ;
d3a7d8c7 77my $index ;
599cee73
PM
78
79sub walk
80{
81 my $tre = shift ;
82 my @list = () ;
83 my ($k, $v) ;
84
95dfd3ab
GS
85 foreach $k (sort keys %$tre) {
86 $v = $tre->{$k};
599cee73
PM
87 die "duplicate key $k\n" if defined $list{$k} ;
88 $Value{$index} = uc $k ;
89 push @{ $list{$k} }, $index ++ ;
90 if (ref $v)
91 { push (@{ $list{$k} }, walk ($v)) }
92 push @list, @{ $list{$k} } ;
93 }
94
95 return @list ;
599cee73
PM
96}
97
98###########################################################################
99
100sub mkRange
101{
102 my @a = @_ ;
103 my @out = @a ;
104 my $i ;
105
106
107 for ($i = 1 ; $i < @a; ++ $i) {
0ca4541c 108 $out[$i] = ".."
599cee73
PM
109 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
110 }
111
112 my $out = join(",",@out);
113
114 $out =~ s/,(\.\.,)+/../g ;
115 return $out;
116}
117
118###########################################################################
e476b1b5
GS
119sub printTree
120{
121 my $tre = shift ;
122 my $prefix = shift ;
123 my $indent = shift ;
124 my ($k, $v) ;
125
126 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
127
128 $prefix .= " " x $indent ;
129 foreach $k (sort keys %$tre) {
130 $v = $tre->{$k};
131 print $prefix . "|\n" ;
132 print $prefix . "+- $k" ;
133 if (ref $v)
0ca4541c 134 {
e476b1b5 135 print " " . "-" x ($max - length $k ) . "+\n" ;
0ca4541c 136 printTree ($v, $prefix . "|" , $max + $indent - 1)
e476b1b5
GS
137 }
138 else
139 { print "\n" }
140 }
141
142}
143
144###########################################################################
599cee73 145
317ea90d 146sub mkHexOct
599cee73 147{
317ea90d 148 my ($f, $max, @a) = @_ ;
599cee73
PM
149 my $mask = "\x00" x $max ;
150 my $string = "" ;
151
152 foreach (@a) {
153 vec($mask, $_, 1) = 1 ;
154 }
155
599cee73 156 foreach (unpack("C*", $mask)) {
317ea90d
MS
157 if ($f eq 'x') {
158 $string .= '\x' . sprintf("%2.2x", $_)
159 }
160 else {
161 $string .= '\\' . sprintf("%o", $_)
162 }
599cee73
PM
163 }
164 return $string ;
165}
166
317ea90d
MS
167sub mkHex
168{
169 my($max, @a) = @_;
170 return mkHexOct("x", $max, @a);
171}
172
173sub mkOct
174{
175 my($max, @a) = @_;
176 return mkHexOct("o", $max, @a);
177}
178
599cee73
PM
179###########################################################################
180
e476b1b5
GS
181if (@ARGV && $ARGV[0] eq "tree")
182{
d3a7d8c7 183 #print " all -+\n" ;
e476b1b5
GS
184 printTree($tree, " ", 4) ;
185 exit ;
186}
599cee73 187
918426be
NC
188unlink "warnings.h";
189unlink "lib/warnings.pm";
4438c4b7
JH
190open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
191open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
599cee73
PM
192
193print WARN <<'EOM' ;
194/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 195 This file is built by warnings.pl
599cee73
PM
196 Any changes made here will be lost!
197*/
198
199
0453d815
PM
200#define Off(x) ((x) / 8)
201#define Bit(x) (1 << ((x) % 8))
599cee73
PM
202#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
203
0453d815 204
599cee73 205#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 206#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
207#define G_WARN_ALL_ON 2 /* -W flag */
208#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 209#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
210#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
211
d3a7d8c7
GS
212#define pWARN_STD Nullsv
213#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
214#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73 215
d3a7d8c7
GS
216#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
217 (x) == pWARN_NONE)
599cee73
PM
218EOM
219
d3a7d8c7
GS
220my $offset = 0 ;
221
222$index = $offset ;
223#@{ $list{"all"} } = walk ($tree) ;
224walk ($tree) ;
599cee73 225
599cee73
PM
226
227$index *= 2 ;
228my $warn_size = int($index / 8) + ($index % 8 != 0) ;
229
230my $k ;
231foreach $k (sort { $a <=> $b } keys %Value) {
232 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
233}
234print WARN "\n" ;
235
236print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
237#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
238print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
239print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
317ea90d
MS
240my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
241
242print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
599cee73
PM
243
244print WARN <<'EOM';
245
d5a71f30
GS
246#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
247#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
248#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
249#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
250#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
251
252#define ckDEAD(x) \
253 ( ! specialWARN(PL_curcop->cop_warnings) && \
254 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
255 isWARNf_on(PL_curcop->cop_warnings, x)))
256
257#define ckWARN(x) \
258 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
259 (PL_curcop->cop_warnings == pWARN_ALL || \
260 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
261 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
262
263#define ckWARN2(x,y) \
264 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
265 (PL_curcop->cop_warnings == pWARN_ALL || \
266 isWARN_on(PL_curcop->cop_warnings, x) || \
267 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
268 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
269
270#define ckWARN_d(x) \
271 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
272 (PL_curcop->cop_warnings != pWARN_NONE && \
273 isWARN_on(PL_curcop->cop_warnings, x) ) )
274
275#define ckWARN2_d(x,y) \
276 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
277 (PL_curcop->cop_warnings != pWARN_NONE && \
278 (isWARN_on(PL_curcop->cop_warnings, x) || \
279 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
280
4438c4b7 281/* end of file warnings.h */
599cee73
PM
282
283EOM
284
285close WARN ;
286
287while (<DATA>) {
288 last if /^KEYWORDS$/ ;
289 print PM $_ ;
290}
291
d3a7d8c7
GS
292#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
293
294#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
295
296print PM "%Offsets = (\n" ;
297foreach my $k (sort { $a <=> $b } keys %Value) {
298 my $v = lc $Value{$k} ;
299 $k *= 2 ;
300 print PM tab(4, " '$v'"), "=> $k,\n" ;
301}
302
303print PM " );\n\n" ;
304
599cee73
PM
305print PM "%Bits = (\n" ;
306foreach $k (sort keys %list) {
307
308 my $v = $list{$k} ;
309 my @list = sort { $a <=> $b } @$v ;
310
0ca4541c
NIS
311 print PM tab(4, " '$k'"), '=> "',
312 # mkHex($warn_size, @list),
313 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
314 '", # [', mkRange(@list), "]\n" ;
315}
316
317print PM " );\n\n" ;
318
319print PM "%DeadBits = (\n" ;
320foreach $k (sort keys %list) {
321
322 my $v = $list{$k} ;
323 my @list = sort { $a <=> $b } @$v ;
324
0ca4541c
NIS
325 print PM tab(4, " '$k'"), '=> "',
326 # mkHex($warn_size, @list),
327 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
328 '", # [', mkRange(@list), "]\n" ;
329}
330
331print PM " );\n\n" ;
d3a7d8c7
GS
332print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
333print PM '$LAST_BIT = ' . "$index ;\n" ;
334print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73
PM
335while (<DATA>) {
336 print PM $_ ;
337}
338
339close PM ;
340
341__END__
342
4438c4b7 343# This file was created by warnings.pl
599cee73
PM
344# Any changes made here will be lost.
345#
346
4438c4b7 347package warnings;
599cee73 348
b75c8c73
MS
349our $VERSION = '1.00';
350
599cee73
PM
351=head1 NAME
352
4438c4b7 353warnings - Perl pragma to control optional warnings
599cee73
PM
354
355=head1 SYNOPSIS
356
4438c4b7
JH
357 use warnings;
358 no warnings;
599cee73 359
4438c4b7
JH
360 use warnings "all";
361 no warnings "all";
599cee73 362
d3a7d8c7
GS
363 use warnings::register;
364 if (warnings::enabled()) {
365 warnings::warn("some warning");
366 }
367
368 if (warnings::enabled("void")) {
e476b1b5
GS
369 warnings::warn("void", "some warning");
370 }
371
7e6d00f8
PM
372 if (warnings::enabled($object)) {
373 warnings::warn($object, "some warning");
374 }
375
721f911b
PM
376 warnings::warnif("some warning");
377 warnings::warnif("void", "some warning");
378 warnings::warnif($object, "some warning");
7e6d00f8 379
599cee73
PM
380=head1 DESCRIPTION
381
0453d815
PM
382If no import list is supplied, all possible warnings are either enabled
383or disabled.
599cee73 384
0ca4541c 385A number of functions are provided to assist module authors.
e476b1b5
GS
386
387=over 4
388
d3a7d8c7
GS
389=item use warnings::register
390
7e6d00f8
PM
391Creates a new warnings category with the same name as the package where
392the call to the pragma is used.
393
394=item warnings::enabled()
395
396Use the warnings category with the same name as the current package.
397
398Return TRUE if that warnings category is enabled in the calling module.
399Otherwise returns FALSE.
400
401=item warnings::enabled($category)
402
403Return TRUE if the warnings category, C<$category>, is enabled in the
404calling module.
405Otherwise returns FALSE.
406
407=item warnings::enabled($object)
408
409Use the name of the class for the object reference, C<$object>, as the
410warnings category.
411
412Return TRUE if that warnings category is enabled in the first scope
413where the object is used.
414Otherwise returns FALSE.
415
416=item warnings::warn($message)
417
418Print C<$message> to STDERR.
419
420Use the warnings category with the same name as the current package.
421
422If that warnings category has been set to "FATAL" in the calling module
423then die. Otherwise return.
424
425=item warnings::warn($category, $message)
426
427Print C<$message> to STDERR.
428
429If the warnings category, C<$category>, has been set to "FATAL" in the
430calling module then die. Otherwise return.
d3a7d8c7 431
7e6d00f8 432=item warnings::warn($object, $message)
e476b1b5 433
7e6d00f8 434Print C<$message> to STDERR.
e476b1b5 435
7e6d00f8
PM
436Use the name of the class for the object reference, C<$object>, as the
437warnings category.
e476b1b5 438
7e6d00f8
PM
439If that warnings category has been set to "FATAL" in the scope where C<$object>
440is first used then die. Otherwise return.
599cee73 441
e476b1b5 442
7e6d00f8
PM
443=item warnings::warnif($message)
444
445Equivalent to:
446
447 if (warnings::enabled())
448 { warnings::warn($message) }
449
450=item warnings::warnif($category, $message)
451
452Equivalent to:
453
454 if (warnings::enabled($category))
455 { warnings::warn($category, $message) }
456
457=item warnings::warnif($object, $message)
458
459Equivalent to:
460
461 if (warnings::enabled($object))
462 { warnings::warn($object, $message) }
d3a7d8c7 463
e476b1b5
GS
464=back
465
749f83fa 466See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
467
468=cut
469
470use Carp ;
471
472KEYWORDS
473
d3a7d8c7
GS
474$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
475
599cee73
PM
476sub bits {
477 my $mask ;
478 my $catmask ;
479 my $fatal = 0 ;
480 foreach my $word (@_) {
327afb7f
GS
481 if ($word eq 'FATAL') {
482 $fatal = 1;
483 }
d3a7d8c7
GS
484 elsif ($catmask = $Bits{$word}) {
485 $mask |= $catmask ;
486 $mask |= $DeadBits{$word} if $fatal ;
599cee73 487 }
d3a7d8c7 488 else
3d1a39c8 489 { croak("Unknown warnings category '$word'")}
599cee73
PM
490 }
491
492 return $mask ;
493}
494
495sub import {
496 shift;
f1f33818
PM
497 my $mask = ${^WARNING_BITS} ;
498 if (vec($mask, $Offsets{'all'}, 1)) {
499 $mask |= $Bits{'all'} ;
500 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
501 }
502 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
599cee73
PM
503}
504
505sub unimport {
506 shift;
d3a7d8c7
GS
507 my $mask = ${^WARNING_BITS} ;
508 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 509 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
510 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
511 }
08540116 512 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
599cee73
PM
513}
514
7e6d00f8 515sub __chk
599cee73 516{
d3a7d8c7
GS
517 my $category ;
518 my $offset ;
7e6d00f8 519 my $isobj = 0 ;
d3a7d8c7
GS
520
521 if (@_) {
522 # check the category supplied.
523 $category = shift ;
7e6d00f8
PM
524 if (ref $category) {
525 croak ("not an object")
3d1a39c8 526 if $category !~ /^([^=]+)=/ ;
7e6d00f8
PM
527 $category = $1 ;
528 $isobj = 1 ;
529 }
d3a7d8c7 530 $offset = $Offsets{$category};
3d1a39c8 531 croak("Unknown warnings category '$category'")
d3a7d8c7
GS
532 unless defined $offset;
533 }
534 else {
0ca4541c 535 $category = (caller(1))[0] ;
d3a7d8c7
GS
536 $offset = $Offsets{$category};
537 croak("package '$category' not registered for warnings")
538 unless defined $offset ;
539 }
540
0ca4541c 541 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
542 my $i = 2 ;
543 my $pkg ;
544
545 if ($isobj) {
546 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
547 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
548 }
549 $i -= 2 ;
550 }
551 else {
552 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
553 last if $pkg ne $this_pkg ;
554 }
0ca4541c 555 $i = 2
7e6d00f8
PM
556 if !$pkg || $pkg eq $this_pkg ;
557 }
558
0ca4541c 559 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
560 return ($callers_bitmask, $offset, $i) ;
561}
562
563sub enabled
564{
565 croak("Usage: warnings::enabled([category])")
566 unless @_ == 1 || @_ == 0 ;
567
568 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
569
570 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
571 return vec($callers_bitmask, $offset, 1) ||
572 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
573}
574
d3a7d8c7 575
e476b1b5
GS
576sub warn
577{
d3a7d8c7
GS
578 croak("Usage: warnings::warn([category,] 'message')")
579 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 580
7e6d00f8
PM
581 my $message = pop ;
582 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
583 local $Carp::CarpLevel = $i ;
0ca4541c 584 croak($message)
d3a7d8c7
GS
585 if vec($callers_bitmask, $offset+1, 1) ||
586 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
587 carp($message) ;
588}
589
7e6d00f8
PM
590sub warnif
591{
592 croak("Usage: warnings::warnif([category,] 'message')")
593 unless @_ == 2 || @_ == 1 ;
594
595 my $message = pop ;
596 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
597 local $Carp::CarpLevel = $i ;
598
0ca4541c 599 return
7e6d00f8
PM
600 unless defined $callers_bitmask &&
601 (vec($callers_bitmask, $offset, 1) ||
602 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
603
0ca4541c 604 croak($message)
7e6d00f8
PM
605 if vec($callers_bitmask, $offset+1, 1) ||
606 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
607
608 carp($message) ;
609}
599cee73 6101;