use vars qw( %ALLOPS %OPMAP @QUEUE_OPCODES_TO_FIX );
CHECK
{
walkallops_filtered( sub { foo( $op ) ... }, \ &queue_opcode );
fix_opcode( $_ ) for @QUEUE_OPCODES_TO_FIX;
}
sub queue_opcode
{
my $op = shift;
push @QUEUE_OPCODES_TO_FIX, $op;
}
sub foo
{
my $op = shift;
my $addr = $$op;
$ALLOPS{ $addr } = $op;
for my $m ( qw( next sibling ppaddr first last other pmreplroot pm
+replstart pmnext ) )
{
my $to = eval { ${ $op->$m } };
next unless $to;
push @{$OPMAP{ $addr }}, "$to $m";
}
}
x_opcode
{
my $op = shift;
my $addr = $$op;
# Construct the new program fragment in reverse order so parent no
+des
# can point to child nodes. See the tree immedia
# null
# or
# $OP
# die
# pushmark
# null2
# gvsv
my $gvsv = B::SVOP->new( gvsv => 2, '$!' );
my $null2 = B::OP->new( null => 6 );
$null2->private( 1 );
my $pushmark = B::OP->new( pushmark => 2 );
my $die = B::LISTOP->new( die => 5, $pushmark, $null2 );
$die->targ( 1 );
$die->private( 1 );
$pushmark->sibling( $null2 );
my $or = B::LOGOP->new( or => 2, $op, $die );
$or->private( 1 );
my $null = B::OP->new( null => 5 );
$null->private( 1 );
# Tree order
my $orig_sibling = $op->sibling;
$op->sibling( $die );
# Now thread the execution order.
my $orig_next = $op->next;
# EXT -> $op
# -> OR
# -> $orig_next || $pushmark
# ( null2 -> gvsv )
# -> gvsv
# -> die
$op->next( $or );
$or->next( $orig_next );
$or->other( $pushmark );
$null->next( $orig_next );
$pushmark->next( $gvsv );
$null2->next( $gvsv ); # Also but this is skipped anyway.
$gvsv->next( $die );
$die->next( $orig_next );
# Now change everything that currently points to $op so that it po
+ints to
my @referrents = @{ $OPMAP{ $addr } };
# use YAML 'Dump';
# print Dump( $addr, \%OPMAP ) or die $!;exit;
foreach my $referrent ( @referrents )
{
my ( $referrent_addr,
$referrent_attr ) = split ' ', $referrent;
print "$$op $referrent_addr $referrent_attr\n" or die $!;
# my $co = B::class( $op );
# my $cn = $op->oldname;
# my $c = B::class( $referrent_obj );
# my $n = $referrent_obj->oldname;
# $referrent_obj->$referrent_attr( $op );
# print STDERR "$referrent_obj->$referrent_attr( $op )\n" or die $!
+;
}
}
|