diff options
author | Todd C. Miller <millert@cvs.openbsd.org> | 2000-04-06 16:11:09 +0000 |
---|---|---|
committer | Todd C. Miller <millert@cvs.openbsd.org> | 2000-04-06 16:11:09 +0000 |
commit | e852ed17d905386f3bbad057fda2f07926227f89 (patch) | |
tree | 9c602984a369e27373c3cd3b71bd8c8e791393f2 /gnu/usr.bin/perl/warnings.pl | |
parent | 9cfdf10e50d1f9e72606c75c7b7a0e18940c80aa (diff) |
virgin perl 5.6.0
Diffstat (limited to 'gnu/usr.bin/perl/warnings.pl')
-rw-r--r-- | gnu/usr.bin/perl/warnings.pl | 492 |
1 files changed, 492 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/warnings.pl b/gnu/usr.bin/perl/warnings.pl new file mode 100644 index 00000000000..61602d5608a --- /dev/null +++ b/gnu/usr.bin/perl/warnings.pl @@ -0,0 +1,492 @@ +#!/usr/bin/perl + +BEGIN { + push @INC, './lib'; +} +use strict ; + +sub DEFAULT_ON () { 1 } +sub DEFAULT_OFF () { 2 } + +my $tree = { + +'all' => { + 'io' => { 'pipe' => DEFAULT_OFF, + 'unopened' => DEFAULT_OFF, + 'closed' => DEFAULT_OFF, + 'newline' => DEFAULT_OFF, + 'exec' => DEFAULT_OFF, + }, + 'syntax' => { 'ambiguous' => DEFAULT_OFF, + 'semicolon' => DEFAULT_OFF, + 'precedence' => DEFAULT_OFF, + 'bareword' => DEFAULT_OFF, + 'reserved' => DEFAULT_OFF, + 'digit' => DEFAULT_OFF, + 'parenthesis' => DEFAULT_OFF, + 'deprecated' => DEFAULT_OFF, + 'printf' => DEFAULT_OFF, + 'prototype' => DEFAULT_OFF, + 'qw' => DEFAULT_OFF, + }, + 'severe' => { 'inplace' => DEFAULT_ON, + 'internal' => DEFAULT_ON, + 'debugging' => DEFAULT_ON, + 'malloc' => DEFAULT_ON, + }, + 'void' => DEFAULT_OFF, + 'recursion' => DEFAULT_OFF, + 'redefine' => DEFAULT_OFF, + 'numeric' => DEFAULT_OFF, + 'uninitialized' => DEFAULT_OFF, + 'once' => DEFAULT_OFF, + 'misc' => DEFAULT_OFF, + 'regexp' => DEFAULT_OFF, + 'glob' => DEFAULT_OFF, + 'y2k' => DEFAULT_OFF, + 'chmod' => DEFAULT_OFF, + 'umask' => DEFAULT_OFF, + 'untie' => DEFAULT_OFF, + 'substr' => DEFAULT_OFF, + 'taint' => DEFAULT_OFF, + 'signal' => DEFAULT_OFF, + 'closure' => DEFAULT_OFF, + 'overflow' => DEFAULT_OFF, + 'portable' => DEFAULT_OFF, + 'utf8' => DEFAULT_OFF, + 'exiting' => DEFAULT_OFF, + 'pack' => DEFAULT_OFF, + 'unpack' => 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 ; + +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 printTree +{ + my $tre = shift ; + my $prefix = shift ; + my $indent = shift ; + my ($k, $v) ; + + my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ; + + $prefix .= " " x $indent ; + foreach $k (sort keys %$tre) { + $v = $tre->{$k}; + print $prefix . "|\n" ; + print $prefix . "+- $k" ; + if (ref $v) + { + print " " . "-" x ($max - length $k ) . "+\n" ; + printTree ($v, $prefix . "|" , $max + $indent - 1) + } + else + { print "\n" } + } + +} + +########################################################################### + +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 ; +} + +########################################################################### + +if (@ARGV && $ARGV[0] eq "tree") +{ + #print " all -+\n" ; + printTree($tree, " ", 4) ; + exit ; +} + +#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 pWARN_STD Nullsv +#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */ +#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */ + +#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ + (x) == pWARN_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 != pWARN_STD && \ + PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ + || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) + +#define ckWARN2(x,y) \ + ( (PL_curcop->cop_warnings != pWARN_STD && \ + PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ + || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) + +#define ckWARN_d(x) \ + (PL_curcop->cop_warnings == pWARN_STD || \ + PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) + +#define ckWARN2_d(x,y) \ + (PL_curcop->cop_warnings == pWARN_STD || \ + PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ + (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) ) + + +#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) +#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) +#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) +#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) + +EOM + +my $offset = 0 ; + +$index = $offset ; +#@{ $list{"all"} } = walk ($tree) ; +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 (<DATA>) { + last if /^KEYWORDS$/ ; + print PM $_ ; +} + +#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ; + +#my %Keys = map {lc $Value{$_}, $_} keys %Value ; + +print PM "%Offsets = (\n" ; +foreach my $k (sort { $a <=> $b } keys %Value) { + my $v = lc $Value{$k} ; + $k *= 2 ; + print PM tab(4, " '$v'"), "=> $k,\n" ; +} + +print PM " );\n\n" ; + +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" ; +print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ; +print PM '$LAST_BIT = ' . "$index ;\n" ; +print PM '$BYTES = ' . "$warn_size ;\n" ; +while (<DATA>) { + 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"; + + use warnings::register; + if (warnings::enabled()) { + warnings::warn("some warning"); + } + + if (warnings::enabled("void")) { + warnings::warn("void", "some warning"); + } + +=head1 DESCRIPTION + +If no import list is supplied, all possible warnings are either enabled +or disabled. + +A number of functions are provided to assist module authors. + +=over 4 + +=item use warnings::register + +Creates a new warnings category which has the same name as the module +where the call to the pragma is used. + +=item warnings::enabled([$category]) + +Returns TRUE if the warnings category C<$category> is enabled in the +calling module. Otherwise returns FALSE. + +If the parameter, C<$category>, isn't supplied, the current package name +will be used. + +=item warnings::warn([$category,] $message) + +If the calling module has I<not> set C<$category> to "FATAL", print +C<$message> to STDERR. +If the calling module has set C<$category> to "FATAL", print C<$message> +STDERR then die. + +If the parameter, C<$category>, isn't supplied, the current package name +will be used. + +=back + +See L<perlmod/Pragmatic Modules> and L<perllexwarn>. + +=cut + +use Carp ; + +KEYWORDS + +$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; + +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 warnings category '$word'")} + } + + return $mask ; +} + +sub import { + shift; + ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ; +} + +sub unimport { + shift; + my $mask = ${^WARNING_BITS} ; + if (vec($mask, $Offsets{'all'}, 1)) { + $mask = $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ; +} + +sub enabled +{ + croak("Usage: warnings::enabled([category])") + unless @_ == 1 || @_ == 0 ; + local $Carp::CarpLevel = 1 ; + my $category ; + my $offset ; + my $callers_bitmask = (caller(1))[9] ; + return 0 unless defined $callers_bitmask ; + + + if (@_) { + # check the category supplied. + $category = shift ; + $offset = $Offsets{$category}; + croak("unknown warnings category '$category'") + unless defined $offset; + } + else { + $category = (caller(0))[0] ; + $offset = $Offsets{$category}; + croak("package '$category' not registered for warnings") + unless defined $offset ; + } + + return vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1) ; +} + + +sub warn +{ + croak("Usage: warnings::warn([category,] 'message')") + unless @_ == 2 || @_ == 1 ; + local $Carp::CarpLevel = 1 ; + my $category ; + my $offset ; + my $callers_bitmask = (caller(1))[9] ; + + if (@_ == 2) { + $category = shift ; + $offset = $Offsets{$category}; + croak("unknown warnings category '$category'") + unless defined $offset ; + } + else { + $category = (caller(0))[0] ; + $offset = $Offsets{$category}; + croak("package '$category' not registered for warnings") + unless defined $offset ; + } + + my $message = shift ; + croak($message) + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; + carp($message) ; +} + +1; |