As diotalevi pointed out in the chatterbox yesterday, this won't work for globals or package variables. So I got to thinking about how best to do it. I did a little more reading before sitting down to rework it.

It still needs work. I could definitely create a few more subroutines to reduce redundant code. It's not perfect either since if you use a lexical scalar in a global hash or a global scalar in a lexical hash, things go haywire.

I went through several different incantations before settling on this one:

#!/usr/bin/perl -w
use strict;
use B::Utils qw(opgrep walkallops_filtered);

package foo;

our $bar = ' delicious';

package str;

our $ing = 'w00t!';

package main;

my $stringy = 'abcde';

our %metoo = (
  key => 3,
  foo => ' delicious',
  string => 'abcde',
);

my $lvalue = \(vec($foo::bar,  0, 32) = 0x5065726C);
ltype($lvalue);

$lvalue = \(keys %metoo = 8);
ltype($lvalue);

$lvalue = \(pos $str::ing = 3);
ltype($lvalue);

$lvalue = \(pos $stringy = 5);
ltype($lvalue);

$lvalue = \substr($stringy, 2);
ltype($lvalue);

$lvalue = \substr($stringy, 1, 2);
ltype($lvalue);

sub lvalue {
  my $ref = shift;
  my $lref = B::svref_2object($ref);
  return undef if $lref !~ /PVLV/;
  my $value = $$ref;
  my $type = $lref->TYPE;
  my $targ = $lref->TARG;
  my $string = $lref->TARG->PV;
  my $offset = $lref->TARGOFF;
  my $length = $lref->TARGLEN;
  my $func;
  if ($type eq 'k') {
    my $hashname = getname($targ);
    my $val = $targ->MAX;
    ++$val;
    $func = "keys $hashname = $val;";
  }
  if ($type eq 'v') {
    my $expr = getname($targ);
    $func = "vec($expr,$offset,$length) = $value;";
  }
  if ($type eq 'x') {
    my $expr = getname($targ);
    $func = "substr($expr,".$offset.','.$length.');';
  }
  if ($type eq '.') {
    my $scalar = getname($targ);
    $func = "pos $scalar = ".$value.';';
  }
  return $func;
}

sub ltype {
  my $lvalue = shift;
  print '$$lvalue = ',$$lvalue,"\n";
  print lvalue($lvalue),$/;
  print $/;
}

sub global_name {
  my $padname = shift;
  my $name = $padname->STASH->NAME.'::'.$padname->SAFENAME;
  $name =~ s/^main:://;
  return $name;
}

sub declassify {
  my %hash = @_;
  for my $key (keys %hash) {
    my $class = B::class($hash{$key});
    $hash{$key} = $hash{$key}->$class;
  }
  return %hash;
}

sub getname {
  my $targ = shift;
  my $class = B::class($targ);
  my $name;
  walkallops_filtered(
    sub {
      my $op = shift;
      if ($class eq 'HV') {
        opgrep({ name => ["padhv", "rv2hv"], next => { name => "keys",
+ },
               }, $op) or return;
      } elsif ($class eq 'PVMG') {
        opgrep({ name => ["padsv", "gvsv"], next => { name => ["pos", 
+"substr"], },
               }, $op) or return;
      } elsif ($class eq 'PV') {
        opgrep({ name => ["padsv", "gvsv"], next => { name => "const",
                 next => { next => { name => "vec", }, }, },
               }, $op) or return;
      }
    },
    sub {
      my $op = shift; 
      my ($padname, $tempname);
      if ($op->name =~ /pad/) {
        $padname = ((B::main_cv->PADLIST->ARRAY)[0]->ARRAY)[$op->targ]
+;
        $tempname = $padname->PV if $padname;
        return () unless $tempname;
        if ($class =~ /PV/) {
          $name = $tempname if ($targ->PV eq eval($tempname));
        } elsif ($class eq 'HV') {
          my %temphash = $targ->ARRAY;
          $name = $tempname if (%temphash eq eval($tempname));
        }
      } elsif ($op->name eq "gvsv") {
        $padname = ((B::main_cv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix
+];
        $tempname = '$'.global_name($padname);
        $name = $tempname if ($targ->PV eq $padname->SV->PV);
      } elsif ($op->name eq "rv2hv") {
        $padname = ((B::main_cv->PADLIST->ARRAY)[1]->ARRAY)[$op->first
+->padix];
        $tempname = '%'.global_name($padname);
        my %padhash = declassify($padname->HV->ARRAY);
        my %targhash = declassify($targ->ARRAY);
        $name = $tempname if (%padhash eq %targhash);
      }
    }
  );
  return $name;
}
[download]