This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: Win32 snag - File::Find File::Spec and Config.pm
[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
PM
145
146sub mkHex
147{
148 my ($max, @a) = @_ ;
149 my $mask = "\x00" x $max ;
150 my $string = "" ;
151
152 foreach (@a) {
153 vec($mask, $_, 1) = 1 ;
154 }
155
156 #$string = unpack("H$max", $mask) ;
157 #$string =~ s/(..)/\x$1/g;
158 foreach (unpack("C*", $mask)) {
159 $string .= '\x' . sprintf("%2.2x", $_) ;
160 }
161 return $string ;
162}
163
164###########################################################################
165
e476b1b5
GS
166if (@ARGV && $ARGV[0] eq "tree")
167{
d3a7d8c7 168 #print " all -+\n" ;
e476b1b5
GS
169 printTree($tree, " ", 4) ;
170 exit ;
171}
599cee73 172
918426be
NC
173unlink "warnings.h";
174unlink "lib/warnings.pm";
4438c4b7
JH
175open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
176open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
599cee73
PM
177
178print WARN <<'EOM' ;
179/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 180 This file is built by warnings.pl
599cee73
PM
181 Any changes made here will be lost!
182*/
183
184
0453d815
PM
185#define Off(x) ((x) / 8)
186#define Bit(x) (1 << ((x) % 8))
599cee73
PM
187#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
188
0453d815 189
599cee73 190#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 191#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
192#define G_WARN_ALL_ON 2 /* -W flag */
193#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 194#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
195#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
196
d3a7d8c7
GS
197#define pWARN_STD Nullsv
198#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
199#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73 200
d3a7d8c7
GS
201#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
202 (x) == pWARN_NONE)
599cee73
PM
203EOM
204
d3a7d8c7
GS
205my $offset = 0 ;
206
207$index = $offset ;
208#@{ $list{"all"} } = walk ($tree) ;
209walk ($tree) ;
599cee73 210
599cee73
PM
211
212$index *= 2 ;
213my $warn_size = int($index / 8) + ($index % 8 != 0) ;
214
215my $k ;
216foreach $k (sort { $a <=> $b } keys %Value) {
217 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
218}
219print WARN "\n" ;
220
221print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
222#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
223print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
224print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
225
226print WARN <<'EOM';
227
d5a71f30
GS
228#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
229#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
230#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
231#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
232#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
233
234#define ckDEAD(x) \
235 ( ! specialWARN(PL_curcop->cop_warnings) && \
236 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
237 isWARNf_on(PL_curcop->cop_warnings, x)))
238
239#define ckWARN(x) \
240 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
241 (PL_curcop->cop_warnings == pWARN_ALL || \
242 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
243 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
244
245#define ckWARN2(x,y) \
246 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
247 (PL_curcop->cop_warnings == pWARN_ALL || \
248 isWARN_on(PL_curcop->cop_warnings, x) || \
249 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
250 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
251
252#define ckWARN_d(x) \
253 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
254 (PL_curcop->cop_warnings != pWARN_NONE && \
255 isWARN_on(PL_curcop->cop_warnings, x) ) )
256
257#define ckWARN2_d(x,y) \
258 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
259 (PL_curcop->cop_warnings != pWARN_NONE && \
260 (isWARN_on(PL_curcop->cop_warnings, x) || \
261 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
262
4438c4b7 263/* end of file warnings.h */
599cee73
PM
264
265EOM
266
267close WARN ;
268
269while (<DATA>) {
270 last if /^KEYWORDS$/ ;
271 print PM $_ ;
272}
273
d3a7d8c7
GS
274#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
275
276#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
277
278print PM "%Offsets = (\n" ;
279foreach my $k (sort { $a <=> $b } keys %Value) {
280 my $v = lc $Value{$k} ;
281 $k *= 2 ;
282 print PM tab(4, " '$v'"), "=> $k,\n" ;
283}
284
285print PM " );\n\n" ;
286
599cee73
PM
287print PM "%Bits = (\n" ;
288foreach $k (sort keys %list) {
289
290 my $v = $list{$k} ;
291 my @list = sort { $a <=> $b } @$v ;
292
0ca4541c
NIS
293 print PM tab(4, " '$k'"), '=> "',
294 # mkHex($warn_size, @list),
295 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
296 '", # [', mkRange(@list), "]\n" ;
297}
298
299print PM " );\n\n" ;
300
301print PM "%DeadBits = (\n" ;
302foreach $k (sort keys %list) {
303
304 my $v = $list{$k} ;
305 my @list = sort { $a <=> $b } @$v ;
306
0ca4541c
NIS
307 print PM tab(4, " '$k'"), '=> "',
308 # mkHex($warn_size, @list),
309 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
310 '", # [', mkRange(@list), "]\n" ;
311}
312
313print PM " );\n\n" ;
d3a7d8c7
GS
314print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
315print PM '$LAST_BIT = ' . "$index ;\n" ;
316print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73
PM
317while (<DATA>) {
318 print PM $_ ;
319}
320
321close PM ;
322
323__END__
324
4438c4b7 325# This file was created by warnings.pl
599cee73
PM
326# Any changes made here will be lost.
327#
328
4438c4b7 329package warnings;
599cee73 330
b75c8c73
MS
331our $VERSION = '1.00';
332
599cee73
PM
333=head1 NAME
334
4438c4b7 335warnings - Perl pragma to control optional warnings
599cee73
PM
336
337=head1 SYNOPSIS
338
4438c4b7
JH
339 use warnings;
340 no warnings;
599cee73 341
4438c4b7
JH
342 use warnings "all";
343 no warnings "all";
599cee73 344
d3a7d8c7
GS
345 use warnings::register;
346 if (warnings::enabled()) {
347 warnings::warn("some warning");
348 }
349
350 if (warnings::enabled("void")) {
e476b1b5
GS
351 warnings::warn("void", "some warning");
352 }
353
7e6d00f8
PM
354 if (warnings::enabled($object)) {
355 warnings::warn($object, "some warning");
356 }
357
358 warnif("some warning");
359 warnif("void", "some warning");
360 warnif($object, "some warning");
361
599cee73
PM
362=head1 DESCRIPTION
363
0453d815
PM
364If no import list is supplied, all possible warnings are either enabled
365or disabled.
599cee73 366
0ca4541c 367A number of functions are provided to assist module authors.
e476b1b5
GS
368
369=over 4
370
d3a7d8c7
GS
371=item use warnings::register
372
7e6d00f8
PM
373Creates a new warnings category with the same name as the package where
374the call to the pragma is used.
375
376=item warnings::enabled()
377
378Use the warnings category with the same name as the current package.
379
380Return TRUE if that warnings category is enabled in the calling module.
381Otherwise returns FALSE.
382
383=item warnings::enabled($category)
384
385Return TRUE if the warnings category, C<$category>, is enabled in the
386calling module.
387Otherwise returns FALSE.
388
389=item warnings::enabled($object)
390
391Use the name of the class for the object reference, C<$object>, as the
392warnings category.
393
394Return TRUE if that warnings category is enabled in the first scope
395where the object is used.
396Otherwise returns FALSE.
397
398=item warnings::warn($message)
399
400Print C<$message> to STDERR.
401
402Use the warnings category with the same name as the current package.
403
404If that warnings category has been set to "FATAL" in the calling module
405then die. Otherwise return.
406
407=item warnings::warn($category, $message)
408
409Print C<$message> to STDERR.
410
411If the warnings category, C<$category>, has been set to "FATAL" in the
412calling module then die. Otherwise return.
d3a7d8c7 413
7e6d00f8 414=item warnings::warn($object, $message)
e476b1b5 415
7e6d00f8 416Print C<$message> to STDERR.
e476b1b5 417
7e6d00f8
PM
418Use the name of the class for the object reference, C<$object>, as the
419warnings category.
e476b1b5 420
7e6d00f8
PM
421If that warnings category has been set to "FATAL" in the scope where C<$object>
422is first used then die. Otherwise return.
599cee73 423
e476b1b5 424
7e6d00f8
PM
425=item warnings::warnif($message)
426
427Equivalent to:
428
429 if (warnings::enabled())
430 { warnings::warn($message) }
431
432=item warnings::warnif($category, $message)
433
434Equivalent to:
435
436 if (warnings::enabled($category))
437 { warnings::warn($category, $message) }
438
439=item warnings::warnif($object, $message)
440
441Equivalent to:
442
443 if (warnings::enabled($object))
444 { warnings::warn($object, $message) }
d3a7d8c7 445
e476b1b5
GS
446=back
447
749f83fa 448See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
449
450=cut
451
452use Carp ;
453
454KEYWORDS
455
d3a7d8c7
GS
456$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
457
599cee73
PM
458sub bits {
459 my $mask ;
460 my $catmask ;
461 my $fatal = 0 ;
462 foreach my $word (@_) {
327afb7f
GS
463 if ($word eq 'FATAL') {
464 $fatal = 1;
465 }
d3a7d8c7
GS
466 elsif ($catmask = $Bits{$word}) {
467 $mask |= $catmask ;
468 $mask |= $DeadBits{$word} if $fatal ;
599cee73 469 }
d3a7d8c7 470 else
0ca4541c 471 { croak("unknown warnings category '$word'")}
599cee73
PM
472 }
473
474 return $mask ;
475}
476
477sub import {
478 shift;
f1f33818
PM
479 my $mask = ${^WARNING_BITS} ;
480 if (vec($mask, $Offsets{'all'}, 1)) {
481 $mask |= $Bits{'all'} ;
482 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
483 }
484 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
599cee73
PM
485}
486
487sub unimport {
488 shift;
d3a7d8c7
GS
489 my $mask = ${^WARNING_BITS} ;
490 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 491 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
492 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
493 }
08540116 494 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
599cee73
PM
495}
496
7e6d00f8 497sub __chk
599cee73 498{
d3a7d8c7
GS
499 my $category ;
500 my $offset ;
7e6d00f8 501 my $isobj = 0 ;
d3a7d8c7
GS
502
503 if (@_) {
504 # check the category supplied.
505 $category = shift ;
7e6d00f8
PM
506 if (ref $category) {
507 croak ("not an object")
508 if $category !~ /^([^=]+)=/ ;+
509 $category = $1 ;
510 $isobj = 1 ;
511 }
d3a7d8c7
GS
512 $offset = $Offsets{$category};
513 croak("unknown warnings category '$category'")
514 unless defined $offset;
515 }
516 else {
0ca4541c 517 $category = (caller(1))[0] ;
d3a7d8c7
GS
518 $offset = $Offsets{$category};
519 croak("package '$category' not registered for warnings")
520 unless defined $offset ;
521 }
522
0ca4541c 523 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
524 my $i = 2 ;
525 my $pkg ;
526
527 if ($isobj) {
528 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
529 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
530 }
531 $i -= 2 ;
532 }
533 else {
534 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
535 last if $pkg ne $this_pkg ;
536 }
0ca4541c 537 $i = 2
7e6d00f8
PM
538 if !$pkg || $pkg eq $this_pkg ;
539 }
540
0ca4541c 541 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
542 return ($callers_bitmask, $offset, $i) ;
543}
544
545sub enabled
546{
547 croak("Usage: warnings::enabled([category])")
548 unless @_ == 1 || @_ == 0 ;
549
550 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
551
552 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
553 return vec($callers_bitmask, $offset, 1) ||
554 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
555}
556
d3a7d8c7 557
e476b1b5
GS
558sub warn
559{
d3a7d8c7
GS
560 croak("Usage: warnings::warn([category,] 'message')")
561 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 562
7e6d00f8
PM
563 my $message = pop ;
564 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
565 local $Carp::CarpLevel = $i ;
0ca4541c 566 croak($message)
d3a7d8c7
GS
567 if vec($callers_bitmask, $offset+1, 1) ||
568 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
569 carp($message) ;
570}
571
7e6d00f8
PM
572sub warnif
573{
574 croak("Usage: warnings::warnif([category,] 'message')")
575 unless @_ == 2 || @_ == 1 ;
576
577 my $message = pop ;
578 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
579 local $Carp::CarpLevel = $i ;
580
0ca4541c 581 return
7e6d00f8
PM
582 unless defined $callers_bitmask &&
583 (vec($callers_bitmask, $offset, 1) ||
584 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
585
0ca4541c 586 croak($message)
7e6d00f8
PM
587 if vec($callers_bitmask, $offset+1, 1) ||
588 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
589
590 carp($message) ;
591}
599cee73 5921;