X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/eb1102fcca2230364ceadea29bd8e87ee51b15fa..0d2925a66a645be5c94e85ffc665c445ed1ca94c:/warnings.pl?ds=sidebyside diff --git a/warnings.pl b/warnings.pl index e5ac703..e7659b9 100644 --- a/warnings.pl +++ b/warnings.pl @@ -1,7 +1,6 @@ #!/usr/bin/perl - -$VERSION = '1.00'; +$VERSION = '1.02'; BEGIN { push @INC, './lib'; @@ -13,56 +12,61 @@ 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, - '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], + '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], + 'threads' => [ 5.008, DEFAULT_OFF], + 'assertions' => [ 5.009, DEFAULT_OFF], + + #'default' => [ 5.008, DEFAULT_ON ], + }], } ; - ########################################################################### sub tab { my($l, $t) = @_; @@ -74,8 +78,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 ; @@ -85,10 +130,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} } ; } @@ -120,20 +172,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" } @@ -180,15 +245,16 @@ sub mkOct if (@ARGV && $ARGV[0] eq "tree") { - #print " all -+\n" ; - printTree($tree, " ", 4) ; + printTree($tree, " ") ; exit ; } unlink "warnings.h"; unlink "lib/warnings.pm"; open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n"; +binmode WARN; open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n"; +binmode PM; print WARN <<'EOM' ; /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! @@ -221,15 +287,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" ; @@ -249,11 +327,6 @@ print WARN <<'EOM'; #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1)) -#define ckDEAD(x) \ - ( ! specialWARN(PL_curcop->cop_warnings) && \ - ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \ - isWARNf_on(PL_curcop->cop_warnings, x))) - #define ckWARN(x) \ ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ (PL_curcop->cop_warnings == pWARN_ALL || \ @@ -267,6 +340,23 @@ print WARN <<'EOM'; isWARN_on(PL_curcop->cop_warnings, y) ) ) \ || (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) +#define ckWARN3(x,y,z) \ + ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ + isWARN_on(PL_curcop->cop_warnings, x) || \ + isWARN_on(PL_curcop->cop_warnings, y) || \ + isWARN_on(PL_curcop->cop_warnings, z) ) ) \ + || (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) + +#define ckWARN4(x,y,z,t) \ + ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ + isWARN_on(PL_curcop->cop_warnings, x) || \ + isWARN_on(PL_curcop->cop_warnings, y) || \ + isWARN_on(PL_curcop->cop_warnings, z) || \ + isWARN_on(PL_curcop->cop_warnings, t) ) ) \ + || (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) + #define ckWARN_d(x) \ (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ (PL_curcop->cop_warnings != pWARN_NONE && \ @@ -278,6 +368,39 @@ print WARN <<'EOM'; (isWARN_on(PL_curcop->cop_warnings, x) || \ isWARN_on(PL_curcop->cop_warnings, y) ) ) ) +#define ckWARN3_d(x,y,z) \ + (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ + (isWARN_on(PL_curcop->cop_warnings, x) || \ + isWARN_on(PL_curcop->cop_warnings, y) || \ + isWARN_on(PL_curcop->cop_warnings, z) ) ) ) + +#define ckWARN4_d(x,y,z,t) \ + (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ + (isWARN_on(PL_curcop->cop_warnings, x) || \ + isWARN_on(PL_curcop->cop_warnings, y) || \ + isWARN_on(PL_curcop->cop_warnings, z) || \ + isWARN_on(PL_curcop->cop_warnings, t) ) ) ) + +#define packWARN(a) (a ) +#define packWARN2(a,b) ((a) | (b)<<8 ) +#define packWARN3(a,b,c) ((a) | (b)<<8 | (c) <<16 ) +#define packWARN4(a,b,c,d) ((a) | (b)<<8 | (c) <<16 | (d) <<24) + +#define unpackWARN1(x) ((x) & 0xFF) +#define unpackWARN2(x) (((x) >>8) & 0xFF) +#define unpackWARN3(x) (((x) >>16) & 0xFF) +#define unpackWARN4(x) (((x) >>24) & 0xFF) + +#define ckDEAD(x) \ + ( ! specialWARN(PL_curcop->cop_warnings) && \ + ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \ + isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \ + isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \ + isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \ + isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))) + /* end of file warnings.h */ EOM @@ -291,18 +414,24 @@ while () { #$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} ; +$last_ver = 0; +print PM "our %Offsets = (\n" ; +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" ; -print PM "%Bits = (\n" ; +print PM "our %Bits = (\n" ; foreach $k (sort keys %list) { my $v = $list{$k} ; @@ -316,7 +445,7 @@ foreach $k (sort keys %list) { print PM " );\n\n" ; -print PM "%DeadBits = (\n" ; +print PM "our %DeadBits = (\n" ; foreach $k (sort keys %list) { my $v = $list{$k} ; @@ -340,13 +469,14 @@ close PM ; __END__ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! # This file was created by warnings.pl # Any changes made here will be lost. # package warnings; -our $VERSION = '1.00'; +our $VERSION = '1.04'; =head1 NAME @@ -373,12 +503,16 @@ warnings - Perl pragma to control optional warnings warnings::warn($object, "some warning"); } - warnif("some warning"); - warnif("void", "some warning"); - warnif($object, "some warning"); + warnings::warnif("some warning"); + warnings::warnif("void", "some warning"); + warnings::warnif($object, "some warning"); =head1 DESCRIPTION +The C pragma is a replacement for the command line flag C<-w>, +but the pragma is limited to the enclosing block, while the flag is global. +See L for more information. + If no import list is supplied, all possible warnings are either enabled or disabled. @@ -467,51 +601,117 @@ See L and L. =cut -use Carp ; - KEYWORDS $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; -sub bits { - my $mask ; +sub Croaker +{ + require Carp; + delete $Carp::CarpInternal{'warnings'}; + Carp::croak(@_); +} + +sub bits +{ + # called from B::Deparse.pm + + push @_, 'all' unless @_; + + my $mask; my $catmask ; my $fatal = 0 ; - foreach my $word (@_) { - if ($word eq 'FATAL') { + my $no_fatal = 0 ; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; } elsif ($catmask = $Bits{$word}) { $mask |= $catmask ; $mask |= $DeadBits{$word} if $fatal ; + $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; } else - { croak("Unknown warnings category '$word'")} + { Croaker("Unknown warnings category '$word'")} } return $mask ; } -sub import { +sub import +{ shift; + + my $catmask ; + my $fatal = 0 ; + my $no_fatal = 0 ; + 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') ; + + push @_, 'all' unless @_; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; + } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; } -sub unimport { +sub unimport +{ shift; + + my $catmask ; 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('FATAL' => (@_ ? @_ : 'all')) | $All) ; + + push @_, 'all' unless @_; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + next; + } + elsif ($catmask = $Bits{$word}) { + $mask &= ~($catmask | $DeadBits{$word} | $All); + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; } +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + sub __chk { my $category ; @@ -521,20 +721,20 @@ sub __chk if (@_) { # check the category supplied. $category = shift ; - if (ref $category) { - croak ("not an object") - if $category !~ /^([^=]+)=/ ; - $category = $1 ; + if (my $type = ref $category) { + Croaker("not an object") + if exists $builtin_type{$type}; + $category = $type; $isobj = 1 ; } $offset = $Offsets{$category}; - croak("Unknown warnings category '$category'") + Croaker("Unknown warnings category '$category'") unless defined $offset; } else { $category = (caller(1))[0] ; $offset = $Offsets{$category}; - croak("package '$category' not registered for warnings") + Croaker("package '$category' not registered for warnings") unless defined $offset ; } @@ -549,20 +749,21 @@ sub __chk $i -= 2 ; } else { - for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { - last if $pkg ne $this_pkg ; - } - $i = 2 - if !$pkg || $pkg eq $this_pkg ; + $i = _error_loc(); # see where Carp will allocate the error } my $callers_bitmask = (caller($i))[9] ; return ($callers_bitmask, $offset, $i) ; } +sub _error_loc { + require Carp::Heavy; + goto &Carp::short_error_loc; # don't introduce another stack frame +} + sub enabled { - croak("Usage: warnings::enabled([category])") + Croaker("Usage: warnings::enabled([category])") unless @_ == 1 || @_ == 0 ; my ($callers_bitmask, $offset, $i) = __chk(@_) ; @@ -575,36 +776,37 @@ sub enabled sub warn { - croak("Usage: warnings::warn([category,] 'message')") + Croaker("Usage: warnings::warn([category,] 'message')") unless @_ == 2 || @_ == 1 ; my $message = pop ; my ($callers_bitmask, $offset, $i) = __chk(@_) ; - local $Carp::CarpLevel = $i ; - croak($message) + require Carp; + Carp::croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; - carp($message) ; + Carp::carp($message) ; } sub warnif { - croak("Usage: warnings::warnif([category,] 'message')") + Croaker("Usage: warnings::warnif([category,] 'message')") unless @_ == 2 || @_ == 1 ; my $message = pop ; my ($callers_bitmask, $offset, $i) = __chk(@_) ; - local $Carp::CarpLevel = $i ; return unless defined $callers_bitmask && (vec($callers_bitmask, $offset, 1) || vec($callers_bitmask, $Offsets{'all'}, 1)) ; - croak($message) + require Carp; + Carp::croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; - carp($message) ; + Carp::carp($message) ; } + 1;