diff options
author | Jarkko Hietaniemi <jhi@iki.fi> | 1999-08-29 10:18:59 +0000 |
---|---|---|
committer | Jarkko Hietaniemi <jhi@iki.fi> | 1999-08-29 10:18:59 +0000 |
commit | 4438c4b75b842b6c829a7da9841e97abb875b1d8 (patch) | |
tree | 559b1a700465df1cb1ae02ada9b9c9e48dd9539f /warning.pl | |
parent | 6dd159d1401b9b9973dd00c1235374efbcb27144 (diff) | |
download | perl-4438c4b75b842b6c829a7da9841e97abb875b1d8.tar.gz |
Rename warning to warnings, from Paul Marquess.
p4raw-id: //depot/cfgperl@4038
Diffstat (limited to 'warning.pl')
-rw-r--r-- | warning.pl | 354 |
1 files changed, 0 insertions, 354 deletions
diff --git a/warning.pl b/warning.pl deleted file mode 100644 index 593b5d7e7c..0000000000 --- a/warning.pl +++ /dev/null @@ -1,354 +0,0 @@ -#!/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 "warning.h"; -#unlink "lib/warning.pm"; -open(WARN, ">warning.h") || die "Can't create warning.h: $!\n"; -open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n"; - -print WARN <<'EOM' ; -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - This file is built by warning.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 warning 'all' */ -#define WARN_NONE (&PL_sv_no) /* no warning '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 warning.h */ - -EOM - -close WARN ; - -while (<DATA>) { - 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 (<DATA>) { - print PM $_ ; -} - -close PM ; - -__END__ - -# This file was created by warning.pl -# Any changes made here will be lost. -# - -package warning; - -=head1 NAME - -warning - Perl pragma to control optional warnings - -=head1 SYNOPSIS - - use warning; - no warning; - - use warning "all"; - no warning "all"; - -=head1 DESCRIPTION - -If no import list is supplied, all possible warnings are either enabled -or disabled. - -See L<perlmod/Pragmatic Modules> and L<perllexwarn>. - - -=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; - $^B |= bits(@_ ? @_ : 'all') ; -} - -sub unimport { - shift; - $^B &= ~ bits(@_ ? @_ : 'all') ; -} - - -sub make_fatal -{ - my $self = shift ; - my $bitmask = $self->bits(@_) ; - $SIG{__WARN__} = - sub - { - die @_ if $^B & $bitmask ; - warn @_ - } ; -} - -sub bitmask -{ - return $^B ; -} - -sub enabled -{ - my $string = shift ; - - return 1 - if $bits{$string} && $^B & $bits{$string} ; - - return 0 ; -} - -1; |