in reply to Discovering the lvaluable function behind the reference
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; }
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.
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re: Re: Discovering the lvaluable function behind the reference
by Mr. Muskrat (Canon) on Jun 04, 2003 at 14:31 UTC |