1. When dealing with MAGIC, you have to remember that its a linked list and a "thing" may have more than one form of magic applied. You have to walk the MAGIC/MOREMAGIC list.
2. Finding out that %imahash is the name of lexical (or global) that was passed in is not trivial. In essense your job becomes: examine your calling context's pad and see if the hash is present there. If so, that's the name. Otherwise you have to find it in the symbol table by doing a search. If that fails then the hash might be present in a Lexical::Typeglob and you aren't going to find it unless you repeat the search except examing the contents of typeglob references as well.

As you probably already know, I have only recently started delving into the magic behind the scenes. Do you have any suggestions for this magician's apprentice?

I think that it would be best, for all parties, if I hold off on attempting #2 until I am more in tune with the magic.

Read all the available documentation: perlguts, perlhack, Gisle Aas' Illustrated PerlGuts, Simon Cozens on modifying the optree, Simon Cozens on perl internals, My own list of interesting links. Get used to using Devel::Peek, read the header files in the source code, heck - read relevant parts of the source code. Even better - create a private build of perl with symbols so you can step through a perl program using the gdb debugger.

Remember to have fun.

/s

Here is an example of my completepartial solution.

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

my $foo = ' delicious';
my $stringy = "abcde";

my %metoo = (
  key => 3,
  foo => $foo,
  string => $stringy,
);

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

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

$lvalue = \(pos $stringy = 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 getname {
  my $targ = shift;
  my $class = B::class($targ);
  my $name;

  walkallops_filtered(
    sub {
      my $op = shift;
      
      if ($class eq 'HV') {
        opgrep( {  name => "padhv",
                   next => {
                     name => "keys",
                   },
                 }, $op) or return;
      } elsif ($class eq 'PVMG') {
        opgrep( {  name => "padsv",
                   next => {
                     name => [ "pos", "substr" ],
                   },
                 }, $op) or return;
       } elsif ($class eq 'PV') {
         opgrep( {  name => "padsv",
                    next => {
                      name => "const",
                      next => {
                        next => {
                          name => "vec",
                        },
                      },
                    },
                  }, $op) or return;
       }
    },
    sub {
      my $op = shift; 
      my $padname = ((B::main_cv->PADLIST->ARRAY)[0]->ARRAY)[$op->targ
+];
      my $tempname = $padname->PV if $padname;
      return () unless $tempname;
      if ($class =~ /PV/) {
        my $temppv = $targ->PV;
        $name = $tempname if ($temppv eq eval($tempname));
      } elsif ($class eq 'HV') {
        my %temphash = $targ->ARRAY;
        $name = $tempname if (%temphash eq eval($tempname));
      }
    }
  );
  return $name;
}
[download]

This outputs:

$$lvalue = 1348825708
vec($foo,0,32) = 1348825708;

$$lvalue = 3
keys %metoo = 8;

$$lvalue = 3
pos $stringy = 3;

$$lvalue = 5
pos $stringy = 5;

$$lvalue = cde
substr($stringy,2,3);

$$lvalue = bc
substr($stringy,1,2);

The magic is in the getname subroutine. It walks the optree looking for specific information. I'll deconstruct it here so that you have a better understanding of how it works.

We stuff the target (B::svref_2object(REF_TO_AN_LVALUE)->TARG) into a scalar $targ. Next we grab the class of the target and store it for later usage. We preclare $name so that we can use it later. Now the real fun starts. We start walking the optree! We use walkallops_filtered which lets us perform a callback function if our filter function finds something.

The first anonymous subroutine is our filter. It grabs the current op and starts to work. We are only interested in HV, PV or PVMG classes.

If our class is HV, it looks for a padhv op followed by a keys op. If it finds that, it returns the padhv op to the callback.

If our class is PVMG, it looks for a padsv op followed by a pos or substr op. If it finds one, it returns the padsv op to the callback.

If our class is PV, it looks for a padsv op followed by a const op and then looks two more ops away for a vec op. If this matches, it returns the padsv op to the callback.

Next is the callback subroutine. It gets the op that was passed to it. Next we do a little magic (I pulled this idea from B::Deparse^*, and it's hard for me to describe what it does) to try and get a padname. If we find a padname, we get the string from it and store it as $tempname. If the string is undef, return. Now we check the classes again.

If class matches /PV/, store the target's PV. If that is equal to the contents of our $tempname (we eval it to get the contents), then we have our variable name, which we store in $name.

If class equals 'HV', create a temporary hash with the contents of $targ->ARRAY (which is really a hash). If the two hashes are the same, we have our variable name, which we store in $name.

Finally we return $name.

I'm sure that if I didn't explain this clearly or accurately enough that some kind soul will correct me.

^* See the code for the padname_sv subroutine.

update: Turns out this doesn't work with globals. Stay tuned for more details.

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]

Woohoo!

I am able to get the variable name on all but one. It just means that the optree for vec is different than that of substr or pos. I am sure that I'll figure out the last one soon enough.

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

my $foo = ' delicious';
my $stringy = "abcde";

my %metoo = (
  key => 3,
  foo => $foo,
  string => $stringy,
);

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

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

$lvalue = \(pos $stringy = 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('$string',$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 getname {
  my $targ = shift;
  my $class = B::class($targ);
  my $name;

  walkallops_filtered(
    sub {
      my $op = shift;
      
      if ($class =~ /PV/) {
        opgrep( {  name => "padsv",
                   next => {
                     name => [ "pos", "substr" ],
                   },
                 }, $op) or return;
      } elsif ($class =~ /HV/) {
        opgrep( {  name => "padhv",
                   next => {
                     name => "keys",
                   },
                 }, $op) or return;
      }
    },
    sub {
      my $op = shift; 
      my $padname = ((B::main_cv->PADLIST->ARRAY)[0]->ARRAY)[$op->targ
+];
      my $tempname = $padname->PV if $padname;
      return () unless $tempname;
      if ($class =~ /PV/) {
        my $temppv = $targ->PV;
        $name = $tempname if ($temppv eq eval($tempname));
      } elsif ($class =~ /HV/) {
        my %temphash = $targ->ARRAY;
        $name = $tempname if (%temphash eq eval($tempname));
      }
    }
  );
  return $name;
}
[download]