From 4438c4b75b842b6c829a7da9841e97abb875b1d8 Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Sun, 29 Aug 1999 10:18:59 +0000 Subject: Rename warning to warnings, from Paul Marquess. p4raw-id: //depot/cfgperl@4038 --- warnings.pl | 336 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 336 insertions(+) create mode 100644 warnings.pl (limited to 'warnings.pl') diff --git a/warnings.pl b/warnings.pl new file mode 100644 index 0000000000..9ff4197612 --- /dev/null +++ b/warnings.pl @@ -0,0 +1,336 @@ +#!/usr/bin/perl + +BEGIN { + push @INC, './lib'; +} +use strict ; + +sub DEFAULT_ON () { 1 } +sub DEFAULT_OFF () { 2 } + +my $tree = { + 'unsafe' => { 'untie' => DEFAULT_OFF, + 'substr' => DEFAULT_OFF, + 'taint' => DEFAULT_OFF, + 'signal' => DEFAULT_OFF, + 'closure' => DEFAULT_OFF, + 'overflow' => DEFAULT_OFF, + 'portable' => DEFAULT_OFF, + 'utf8' => DEFAULT_OFF, + } , + 'io' => { 'pipe' => DEFAULT_OFF, + 'unopened' => DEFAULT_OFF, + 'closed' => DEFAULT_OFF, + 'newline' => DEFAULT_OFF, + 'exec' => DEFAULT_OFF, + #'wr in in file'=> DEFAULT_OFF, + }, + 'syntax' => { 'ambiguous' => DEFAULT_OFF, + 'semicolon' => DEFAULT_OFF, + 'precedence' => DEFAULT_OFF, + 'reserved' => DEFAULT_OFF, + 'octal' => DEFAULT_OFF, + 'digit' => DEFAULT_OFF, + 'parenthesis' => DEFAULT_OFF, + 'deprecated' => DEFAULT_OFF, + 'printf' => DEFAULT_OFF, + }, + 'severe' => { 'inplace' => DEFAULT_ON, + 'internal' => DEFAULT_ON, + 'debugging' => DEFAULT_ON, + }, + 'void' => DEFAULT_OFF, + 'recursion' => DEFAULT_OFF, + 'redefine' => DEFAULT_OFF, + 'numeric' => DEFAULT_OFF, + 'uninitialized'=> DEFAULT_OFF, + 'once' => DEFAULT_OFF, + 'misc' => DEFAULT_OFF, + #'default' => DEFAULT_ON, + } ; + + +########################################################################### +sub tab { + my($l, $t) = @_; + $t .= "\t" x ($l - (length($t) + 1) / 8); + $t; +} + +########################################################################### + +my %list ; +my %Value ; +my $index = 0 ; + +sub walk +{ + my $tre = shift ; + my @list = () ; + my ($k, $v) ; + + foreach $k (sort keys %$tre) { + $v = $tre->{$k}; + die "duplicate key $k\n" if defined $list{$k} ; + $Value{$index} = uc $k ; + push @{ $list{$k} }, $index ++ ; + if (ref $v) + { push (@{ $list{$k} }, walk ($v)) } + push @list, @{ $list{$k} } ; + } + + return @list ; +} + +########################################################################### + +sub mkRange +{ + my @a = @_ ; + my @out = @a ; + my $i ; + + + for ($i = 1 ; $i < @a; ++ $i) { + $out[$i] = ".." + if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ; + } + + my $out = join(",",@out); + + $out =~ s/,(\.\.,)+/../g ; + return $out; +} + +########################################################################### + +sub mkHex +{ + my ($max, @a) = @_ ; + my $mask = "\x00" x $max ; + my $string = "" ; + + foreach (@a) { + vec($mask, $_, 1) = 1 ; + } + + #$string = unpack("H$max", $mask) ; + #$string =~ s/(..)/\x$1/g; + foreach (unpack("C*", $mask)) { + $string .= '\x' . sprintf("%2.2x", $_) ; + } + return $string ; +} + +########################################################################### + + +#unlink "warnings.h"; +#unlink "lib/warnings.pm"; +open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n"; +open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n"; + +print WARN <<'EOM' ; +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! + This file is built by warnings.pl + Any changes made here will be lost! +*/ + + +#define Off(x) ((x) / 8) +#define Bit(x) (1 << ((x) % 8)) +#define IsSet(a, x) ((a)[Off(x)] & Bit(x)) + + +#define G_WARN_OFF 0 /* $^W == 0 */ +#define G_WARN_ON 1 /* -w flag and $^W != 0 */ +#define G_WARN_ALL_ON 2 /* -W flag */ +#define G_WARN_ALL_OFF 4 /* -X flag */ +#define G_WARN_ONCE 8 /* set if 'once' ever enabled */ +#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) + +#define WARN_STD Nullsv +#define WARN_ALL (&PL_sv_yes) /* use warnings 'all' */ +#define WARN_NONE (&PL_sv_no) /* no warnings 'all' */ + +#define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \ + (x) == WARN_NONE) + +#define ckDEAD(x) \ + ( ! specialWARN(PL_curcop->cop_warnings) && \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) + +#define ckWARN(x) \ + ( (PL_curcop->cop_warnings != WARN_STD && \ + PL_curcop->cop_warnings != WARN_NONE && \ + (PL_curcop->cop_warnings == WARN_ALL || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ + || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) + +#define ckWARN2(x,y) \ + ( (PL_curcop->cop_warnings != WARN_STD && \ + PL_curcop->cop_warnings != WARN_NONE && \ + (PL_curcop->cop_warnings == WARN_ALL || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ + || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) + +#define ckWARN_d(x) \ + (PL_curcop->cop_warnings == WARN_STD || \ + PL_curcop->cop_warnings == WARN_ALL || \ + (PL_curcop->cop_warnings != WARN_NONE && \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) + +#define ckWARN2_d(x,y) \ + (PL_curcop->cop_warnings == WARN_STD || \ + PL_curcop->cop_warnings == WARN_ALL || \ + (PL_curcop->cop_warnings != WARN_NONE && \ + (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) ) + + +#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD) +#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD) +#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) +#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) + +EOM + + +$index = 0 ; +@{ $list{"all"} } = walk ($tree) ; + +$index *= 2 ; +my $warn_size = int($index / 8) + ($index % 8 != 0) ; + +my $k ; +foreach $k (sort { $a <=> $b } keys %Value) { + print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ; +} +print WARN "\n" ; + +print WARN tab(5, '#define WARNsize'), "$warn_size\n" ; +#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ; +print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ; +print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ; + +print WARN <<'EOM'; + +/* end of file warnings.h */ + +EOM + +close WARN ; + +while () { + last if /^KEYWORDS$/ ; + print PM $_ ; +} + +$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ; +print PM "%Bits = (\n" ; +foreach $k (sort keys %list) { + + my $v = $list{$k} ; + my @list = sort { $a <=> $b } @$v ; + + print PM tab(4, " '$k'"), '=> "', + # mkHex($warn_size, @list), + mkHex($warn_size, map $_ * 2 , @list), + '", # [', mkRange(@list), "]\n" ; +} + +print PM " );\n\n" ; + +print PM "%DeadBits = (\n" ; +foreach $k (sort keys %list) { + + my $v = $list{$k} ; + my @list = sort { $a <=> $b } @$v ; + + print PM tab(4, " '$k'"), '=> "', + # mkHex($warn_size, @list), + mkHex($warn_size, map $_ * 2 + 1 , @list), + '", # [', mkRange(@list), "]\n" ; +} + +print PM " );\n\n" ; +while () { + print PM $_ ; +} + +close PM ; + +__END__ + +# This file was created by warnings.pl +# Any changes made here will be lost. +# + +package warnings; + +=head1 NAME + +warnings - Perl pragma to control optional warnings + +=head1 SYNOPSIS + + use warnings; + no warnings; + + use warnings "all"; + no warnings "all"; + +=head1 DESCRIPTION + +If no import list is supplied, all possible warnings are either enabled +or disabled. + +See L and L. + + +=cut + +use Carp ; + +KEYWORDS + +sub bits { + my $mask ; + my $catmask ; + my $fatal = 0 ; + foreach my $word (@_) { + if ($word eq 'FATAL') + { $fatal = 1 } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + } + else + { croak "unknown warning category '$word'" } + } + + return $mask ; +} + +sub import { + shift; + ${^Warnings} |= bits(@_ ? @_ : 'all') ; +} + +sub unimport { + shift; + ${^Warnings} &= ~ bits(@_ ? @_ : 'all') ; +} + +sub enabled +{ + my $string = shift ; + + return 1 + if $bits{$string} && ${^Warnings} & $bits{$string} ; + + return 0 ; +} + +1; -- cgit v1.2.1