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 = <DATA>) {
    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'}


##</code><code>##

Name "main::OUT" used only once: possible typo at /home/lanx/pm/warn_undef.pl line 141.
*** TESTING["hash_ref", "\$h->{a}"] at /home/lanx/pm/warn_undef.pl line 138, <DATA> line 2.
Use of uninitialized value $$h{'a'} in concatenation (.) or string at (eval 10) line 2, <DATA> line 2.
Use of uninitialized value $$h{'a'} in printf at (eval 12) line 2, <DATA> line 2.
Use of uninitialized value $$h{'a'} in sprintf at (eval 14) line 2, <DATA> line 2.
Use of uninitialized values $$h{'a'} $$h{'a'} in concatenation (.) or string at (eval 16) line 2, <DATA> line 2.
Use of uninitialized values $$h{'a'} $$h{'a'} in printf at (eval 19) line 2, <DATA> line 2.
Use of uninitialized values $$h{'a'} $$h{'a'} in sprintf at (eval 22) line 2, <DATA> line 2.
*** TESTING["hoa_ref", "\$h->{b}[0]"] at /home/lanx/pm/warn_undef.pl line 138, <DATA> line 3.
Use of uninitialized value $$h{'b'}[0] in concatenation (.) or string at (eval 25) line 2, <DATA> line 3.
Use of uninitialized value $$h{'b'}[0] in printf at (eval 27) line 2, <DATA> line 3.
Use of uninitialized value $$h{'b'}[0] in sprintf at (eval 29) line 2, <DATA> line 3.
Use of uninitialized values $$h{'b'}[0] $$h{'b'}[0] in concatenation (.) or string at (eval 31) line 2, <DATA> line 3.
Use of uninitialized values $$h{'b'}[0] $$h{'b'}[0] in printf at (eval 34) line 2, <DATA> line 3.
Use of uninitialized values $$h{'b'}[0] $$h{'b'}[0] in sprintf at (eval 37) line 2, <DATA> line 3.
*** TESTING["hash", "\$hash{a}"] at /home/lanx/pm/warn_undef.pl line 138, <DATA> line 5.
Use of uninitialized value $hash{"a"} in concatenation (.) or string at (eval 40) line 2, <DATA> line 5.
Use of uninitialized value $hash{"a"} in printf at (eval 41) line 2, <DATA> line 5.
Use of uninitialized value $hash{"a"} in sprintf at (eval 42) line 2, <DATA> line 5.
Use of uninitialized value $hash{"a"} in concatenation (.) or string at (eval 43) line 2, <DATA> line 5.
Use of uninitialized value $hash{"a"} in concatenation (.) or string at (eval 43) line 2, <DATA> line 5.
Use of uninitialized value $hash{"a"} in printf at (eval 44) line 2, <DATA> line 5.
Use of uninitialized value $hash{"a"} in printf at (eval 44) line 2, <DATA> line 5.
Use of uninitialized value $hash{"a"} in sprintf at (eval 45) line 2, <DATA> line 5.
Use of uninitialized value $hash{"a"} in sprintf at (eval 45) line 2, <DATA> line 5.
*** TESTING["hoa", "\$hash{b}[0]"] at /home/lanx/pm/warn_undef.pl line 138, <DATA> line 6.
Use of uninitialized value $hash{'b'}[0] in concatenation (.) or string at (eval 46) line 2, <DATA> line 6.
Use of uninitialized value $hash{'b'}[0] in printf at (eval 48) line 2, <DATA> line 6.
Use of uninitialized value $hash{'b'}[0] in sprintf at (eval 50) line 2, <DATA> line 6.
Use of uninitialized values $hash{'b'}[0] $hash{'b'}[0] in concatenation (.) or string at (eval 52) line 2, <DATA> line 6.
Use of uninitialized values $hash{'b'}[0] $hash{'b'}[0] in printf at (eval 55) line 2, <DATA> line 6.
Use of uninitialized values $hash{'b'}[0] $hash{'b'}[0] in sprintf at (eval 58) line 2, <DATA> line 6.
*** TESTING["array", "\$array[1]"] at /home/lanx/pm/warn_undef.pl line 138, <DATA> line 8.
Use of uninitialized value $array[1] in concatenation (.) or string at (eval 61) line 2, <DATA> line 8.
Use of uninitialized value $array[1] in printf at (eval 62) line 2, <DATA> line 8.
Use of uninitialized value $array[1] in sprintf at (eval 64) line 2, <DATA> line 8.
Use of uninitialized value $array[1] in concatenation (.) or string at (eval 65) line 2, <DATA> line 8.
Use of uninitialized values $array[1] $array[1] in concatenation (.) or string at (eval 65) line 2, <DATA> line 8.
Use of uninitialized values $array[1] $array[1] in printf at (eval 68) line 2, <DATA> line 8.
Use of uninitialized values $array[1] $array[1] in sprintf at (eval 71) line 2, <DATA> line 8.
*** TESTING["aoh", "\$array[0]{a}"] at /home/lanx/pm/warn_undef.pl line 138, <DATA> line 9.
Use of uninitialized value $array[0]{'a'} in concatenation (.) or string at (eval 74) line 2, <DATA> line 9.
Use of uninitialized value $array[0]{'a'} in printf at (eval 76) line 2, <DATA> line 9.
Use of uninitialized value $array[0]{'a'} in sprintf at (eval 78) line 2, <DATA> line 9.
Use of uninitialized values $array[0]{'a'} $array[0]{'a'} in concatenation (.) or string at (eval 80) line 2, <DATA> line 9.
Use of uninitialized values $array[0]{'a'} $array[0]{'a'} in printf at (eval 83) line 2, <DATA> line 9.
Use of uninitialized values $array[0]{'a'} $array[0]{'a'} in sprintf at (eval 86) line 2, <DATA> line 9.
*** TESTING["array_ref", "\$a->[1]"] at /home/lanx/pm/warn_undef.pl line 138, <DATA> line 11.
Use of uninitialized value $$a[1] in concatenation (.) or string at (eval 89) line 2, <DATA> line 11.
Use of uninitialized value $$a[1] in printf at (eval 91) line 2, <DATA> line 11.
Use of uninitialized value $$a[1] in sprintf at (eval 93) line 2, <DATA> line 11.
Use of uninitialized values $$a[1] $$a[1] in concatenation (.) or string at (eval 95) line 2, <DATA> line 11.
Use of uninitialized values $$a[1] $$a[1] in printf at (eval 98) line 2, <DATA> line 11.
Use of uninitialized values $$a[1] $$a[1] in sprintf at (eval 101) line 2, <DATA> line 11.
*** TESTING["aoh_ref", "\$a->[0]{a}"] at /home/lanx/pm/warn_undef.pl line 138, <DATA> line 12.
Use of uninitialized value $$a[0]{'a'} in concatenation (.) or string at (eval 104) line 2, <DATA> line 12.
Use of uninitialized value $$a[0]{'a'} in printf at (eval 106) line 2, <DATA> line 12.
Use of uninitialized value $$a[0]{'a'} in sprintf at (eval 108) line 2, <DATA> line 12.
Use of uninitialized values $$a[0]{'a'} $$a[0]{'a'} in concatenation (.) or string at (eval 110) line 2, <DATA> line 12.
Use of uninitialized values $$a[0]{'a'} $$a[0]{'a'} in printf at (eval 113) line 2, <DATA> line 12.
Use of uninitialized values $$a[0]{'a'} $$a[0]{'a'} in sprintf at (eval 116) line 2, <DATA> line 12.