From: Paul Marquess Date: Sat, 18 May 2002 21:15:43 +0000 (+0100) Subject: RE: perl@16678 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0d658bf5a06395c253c09769a32f6face7d329cb;p=p5sagit%2Fp5-mst-13.2.git RE: perl@16678 From: "Paul Marquess" Message-ID: Making the symbols generated by warnings.pl future-proof. p4raw-id: //depot/perl@16682 --- diff --git a/lib/warnings.pm b/lib/warnings.pm index 7f7e175..78ac4a9 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -129,6 +129,9 @@ See L and L. use Carp ; %Offsets = ( + + # Warnings Categories added in Perl 5.008 + 'all' => 0, 'closure' => 2, 'deprecated' => 4, @@ -419,4 +422,5 @@ sub warnif carp($message) ; } + 1; diff --git a/warnings.h b/warnings.h index 3da705e..9de1678 100644 --- a/warnings.h +++ b/warnings.h @@ -22,6 +22,9 @@ #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ (x) == pWARN_NONE) + +/* Warnings Categories added in Perl 5.008 */ + #define WARN_ALL 0 #define WARN_CLOSURE 1 #define WARN_DEPRECATED 2 diff --git a/warnings.pl b/warnings.pl index caa4954..0e905c0 100644 --- a/warnings.pl +++ b/warnings.pl @@ -13,57 +13,59 @@ sub DEFAULT_OFF () { 2 } my $tree = { -'all' => { - 'io' => { 'pipe' => DEFAULT_OFF, - 'unopened' => DEFAULT_OFF, - 'closed' => DEFAULT_OFF, - 'newline' => DEFAULT_OFF, - 'exec' => DEFAULT_OFF, - 'layer' => DEFAULT_OFF, - }, - 'syntax' => { 'ambiguous' => DEFAULT_OFF, - 'semicolon' => DEFAULT_OFF, - 'precedence' => DEFAULT_OFF, - 'bareword' => DEFAULT_OFF, - 'reserved' => DEFAULT_OFF, - 'digit' => DEFAULT_OFF, - 'parenthesis' => DEFAULT_OFF, - 'printf' => DEFAULT_OFF, - 'prototype' => DEFAULT_OFF, - 'qw' => DEFAULT_OFF, - }, - 'severe' => { 'inplace' => DEFAULT_ON, - 'internal' => DEFAULT_ON, - 'debugging' => DEFAULT_ON, - 'malloc' => DEFAULT_ON, - }, - 'deprecated' => DEFAULT_OFF, - '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, - '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, - } +'all' => [ 5.008, { + 'io' => [ 5.008, { + 'pipe' => [ 5.008, DEFAULT_OFF], + 'unopened' => [ 5.008, DEFAULT_OFF], + 'closed' => [ 5.008, DEFAULT_OFF], + 'newline' => [ 5.008, DEFAULT_OFF], + 'exec' => [ 5.008, DEFAULT_OFF], + 'layer' => [ 5.008, DEFAULT_OFF], + }], + 'syntax' => [ 5.008, { + 'ambiguous' => [ 5.008, DEFAULT_OFF], + 'semicolon' => [ 5.008, DEFAULT_OFF], + 'precedence' => [ 5.008, DEFAULT_OFF], + 'bareword' => [ 5.008, DEFAULT_OFF], + 'reserved' => [ 5.008, DEFAULT_OFF], + 'digit' => [ 5.008, DEFAULT_OFF], + 'parenthesis' => [ 5.008, DEFAULT_OFF], + 'printf' => [ 5.008, DEFAULT_OFF], + 'prototype' => [ 5.008, DEFAULT_OFF], + 'qw' => [ 5.008, DEFAULT_OFF], + }], + 'severe' => [ 5.008, { + 'inplace' => [ 5.008, DEFAULT_ON], + 'internal' => [ 5.008, DEFAULT_ON], + 'debugging' => [ 5.008, DEFAULT_ON], + 'malloc' => [ 5.008, DEFAULT_ON], + }], + 'deprecated' => [ 5.008, DEFAULT_OFF], + 'void' => [ 5.008, DEFAULT_OFF], + 'recursion' => [ 5.008, DEFAULT_OFF], + 'redefine' => [ 5.008, DEFAULT_OFF], + 'numeric' => [ 5.008, DEFAULT_OFF], + 'uninitialized' => [ 5.008, DEFAULT_OFF], + 'once' => [ 5.008, DEFAULT_OFF], + 'misc' => [ 5.008, DEFAULT_OFF], + 'regexp' => [ 5.008, DEFAULT_OFF], + 'glob' => [ 5.008, DEFAULT_OFF], + 'y2k' => [ 5.008, DEFAULT_OFF], + 'untie' => [ 5.008, DEFAULT_OFF], + 'substr' => [ 5.008, DEFAULT_OFF], + 'taint' => [ 5.008, DEFAULT_OFF], + 'signal' => [ 5.008, DEFAULT_OFF], + 'closure' => [ 5.008, DEFAULT_OFF], + 'overflow' => [ 5.008, DEFAULT_OFF], + 'portable' => [ 5.008, DEFAULT_OFF], + 'utf8' => [ 5.008, DEFAULT_OFF], + 'exiting' => [ 5.008, DEFAULT_OFF], + 'pack' => [ 5.008, DEFAULT_OFF], + 'unpack' => [ 5.008, DEFAULT_OFF], + #'default' => [ 5.008, DEFAULT_ON ], + }], } ; - ########################################################################### sub tab { my($l, $t) = @_; @@ -75,8 +77,49 @@ sub tab { my %list ; my %Value ; +my %ValueToName ; +my %NameToValue ; my $index ; +my %v_list = () ; + +sub valueWalk +{ + 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} ; + die "Value associated with key '$k' is not an ARRAY reference" + if !ref $v || ref $v ne 'ARRAY' ; + + my ($ver, $rest) = @{ $v } ; + push @{ $v_list{$ver} }, $k; + + if (ref $rest) + { valueWalk ($rest) } + + } + +} + +sub orderValues +{ + my $index = 0; + foreach my $ver ( sort { $a <=> $b } keys %v_list ) { + foreach my $name (@{ $v_list{$ver} } ) { + $ValueToName{ $index } = [ uc $name, $ver ] ; + $NameToValue{ uc $name } = $index ++ ; + } + } + + return $index ; +} + +########################################################################### + sub walk { my $tre = shift ; @@ -86,10 +129,17 @@ sub walk 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)) } + #$Value{$index} = uc $k ; + die "Can't find key '$k'" + if ! defined $NameToValue{uc $k} ; + push @{ $list{$k} }, $NameToValue{uc $k} ; + die "Value associated with key '$k' is not an ARRAY reference" + if !ref $v || ref $v ne 'ARRAY' ; + + my ($ver, $rest) = @{ $v } ; + if (ref $rest) + { push (@{ $list{$k} }, walk ($rest)) } + push @list, @{ $list{$k} } ; } @@ -121,20 +171,33 @@ sub printTree { my $tre = shift ; my $prefix = shift ; - my $indent = shift ; my ($k, $v) ; my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ; + my @keys = sort keys %$tre ; - $prefix .= " " x $indent ; - foreach $k (sort keys %$tre) { + while ($k = shift @keys) { $v = $tre->{$k}; - print $prefix . "|\n" ; - print $prefix . "+- $k" ; - if (ref $v) + die "Value associated with key '$k' is not an ARRAY reference" + if !ref $v || ref $v ne 'ARRAY' ; + + my $offset ; + if ($tre ne $tree) { + print $prefix . "|\n" ; + print $prefix . "+- $k" ; + $offset = ' ' x ($max + 4) ; + } + else { + print $prefix . "$k" ; + $offset = ' ' x ($max + 1) ; + } + + my ($ver, $rest) = @{ $v } ; + if (ref $rest) { - print " " . "-" x ($max - length $k ) . "+\n" ; - printTree ($v, $prefix . "|" , $max + $indent - 1) + my $bar = @keys ? "|" : " "; + print " -" . "-" x ($max - length $k ) . "+\n" ; + printTree ($rest, $prefix . $bar . $offset ) } else { print "\n" } @@ -181,8 +244,7 @@ sub mkOct if (@ARGV && $ARGV[0] eq "tree") { - #print " all -+\n" ; - printTree($tree, " ", 4) ; + printTree($tree, " ") ; exit ; } @@ -222,19 +284,27 @@ my $offset = 0 ; $index = $offset ; #@{ $list{"all"} } = walk ($tree) ; -walk ($tree) ; +valueWalk ($tree) ; +my $index = orderValues(); die < 255 ; Too many warnings categories -- max is 255 rewrite packWARN* & unpackWARN* macros EOM +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" ; +my $last_ver = 0; +foreach $k (sort { $a <=> $b } keys %ValueToName) { + my ($name, $version) = @{ $ValueToName{$k} }; + print WARN "\n/* Warnings Categories added in Perl $version */\n\n" + if $last_ver != $version ; + print WARN tab(5, "#define WARN_$name"), "$k\n" ; + $last_ver = $version ; } print WARN "\n" ; @@ -341,13 +411,19 @@ while () { #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ; -#my %Keys = map {lc $Value{$_}, $_} keys %Value ; - +$last_ver = 0; print PM "%Offsets = (\n" ; -foreach my $k (sort { $a <=> $b } keys %Value) { - my $v = lc $Value{$k} ; +foreach my $k (sort { $a <=> $b } keys %ValueToName) { + my ($name, $version) = @{ $ValueToName{$k} }; + $name = lc $name; $k *= 2 ; - print PM tab(4, " '$v'"), "=> $k,\n" ; + if ( $last_ver != $version ) { + print PM "\n"; + print PM tab(4, " # Warnings Categories added in Perl $version"); + print PM "\n\n"; + } + print PM tab(4, " '$name'"), "=> $k,\n" ; + $last_ver = $version; } print PM " );\n\n" ; @@ -661,4 +737,5 @@ sub warnif carp($message) ; } + 1;