use strict; use warnings; use Data::Dump qw/pp dd/; use B::Deparse qw/coderef2text/; use PadWalker qw/peek_my/; my %warncache; my $result; BEGIN { $SIG{__WARN__} = sub { my ($err)=@_; # ignore other warnings unless ($err =~ m/^(Use of uninitialized value) (in (\w+) .*)$/) { warn "$err"; return; } # ignore other undef vars return if $warncache{$err}++; my ($msg_start, $msg_end, $msg_type) =($1,$2,$3); #warn "* OrigWarn:\t $err"; my ($file,$line) = (caller(0))[1,2]; my $subname = (caller(1))[3]; my ($subref,$subline) = get_subline($subname,$file,$line,$err); #warn "LINE:<$subline>"; my $peek_sub = PadWalker::peek_sub ($subref); my $sep = { concatenation => '\\.', printf => ',', sprintf => ',', }->{$msg_type}; my $chomp = { sprintf => '\)', }->{$msg_type}; $subline =~ s/$chomp$// if $chomp; my @split = split /\s*$sep\s*/, $subline; #dd [$subline, @split, $peek_sub]; my @undefined; for my $snippet ( @split) { while ( my ($var,$ref) = each %$peek_sub){ $var =~ s/^\%/\$/; $var =~ s/^\@/\$/; my $match="\\$var"; if ( $snippet =~ /^(.*?)($match)(.*)$/ ) { my $new="$1\$ref$3"; #warn "match VAR <$match> in $snippet as $new"; next if defined eval($new); #warn "UNDEF $snippet"; push @undefined, $snippet; } } } #dd \@undefined; # build new warning my $plural = @undefined > 1 ? "s" :""; my $new_err = "${msg_start}$plural @undefined $msg_end"; warn # ". NewWarn:\t". "$new_err\n"; $result = { oldmsg => $err, newmsg => $new_err, vars => [@undefined], line => $subline, split => [@split], peek => $peek_sub, }; }; } sub get_subline { my ($name,$file,$line,$err) =@_; #dd \@_; my $subref = \&{$name}; my $subbody = B::Deparse->new('-q','-l','-x0')->coderef2text($subref); my $start = "#line \Q$line\E \"\Q$file\E\"\n"; my $end = "\n(#line|})"; #warn $subbody; #dd "match:", $subbody =~ m/($start)/; my ($subline) = $subbody =~ m/$start\s+(.*?);$end/s; return ($subref, $subline); } #warn "Version $]"; my %hash=(a=>undef,b=>[]); my $h=\%hash; my @array=({a=>undef}); my $a=\@array; while (my $case = ) { chomp $case; next unless $case; next if $case =~ /^#/; my ($name,$var) = split /\s*:\s*/,$case; warn "*** TESTING".pp [$name,$var]; no warnings 'redefine'; my $out =""; open OUT,">",\$out; my @lines = ( # one undef var qq# print OUT "$name: $var"; #, qq# printf OUT '$name %s',$var; #, qq# print OUT sprintf '$name %s',$var; #, # multiple undef vars qq# print OUT "$name: $var $var" #, qq# printf OUT '$name %s %s',$var,$var; #, qq# print OUT sprintf '$name %s %s',$var,$var; #, ); for my $line (@lines) { my $code = <<"__CODE__"; sub tst { $line }; __CODE__ eval $code; if ($@) { warn "SKIPPING TEST $@ in \n<<<$code>>>"; next; } undef $result; tst(); die "$case", pp $result if $result and not @{$result->{vars}}; #warn pp $code,$result; } #last; } exit; __DATA__ hash_ref: $h->{a} hoa_ref: $h->{b}[0] hash: $hash{a} hoa: $hash{b}[0] array: $array[1] aoh: $array[0]{a} array_ref:$a->[1] aoh_ref: $a->[0]{a} #aoh_ref: $a->[$b]{'a b'}