1#!./perl 2 3BEGIN { 4 unshift @INC, 't'; 5 require Config; 6 if (($Config::Config{'extensions'} !~ /\bB\b/) ){ 7 print "1..0 # Skip -- Perl configured without B module\n"; 8 exit 0; 9 } 10} 11 12use warnings; 13use strict; 14use Test::More; 15 16BEGIN { use_ok( 'B' ); } 17 18# Somewhat minimal tests. 19 20my %seen; 21 22sub B::OP::pie { 23 my $self = shift; 24 return ++$seen{$self->name}; 25} 26 27my %debug; 28sub B::OP::walkoptree_debug { 29 my $self = shift; 30 return ++$debug{$self->name}; 31} 32 33my $victim = sub { 34 # This gives us a substcont, which gets to the second recursive call 35 # point (in the if statement in the XS code) 36 $_[0] =~ s/(a)/ $1/; 37 # PMOP_pmreplroot(cPMOPo) is NULL for this 38 $_[0] =~ s/(b)//; 39 # This gives an OP_SPLIT 40 split /c/; 41}; 42 43is (B::walkoptree_debug, 0, 'walkoptree_debug() is 0'); 44B::walkoptree(B::svref_2object($victim)->ROOT, "pie"); 45foreach (qw(substcont split split leavesub)) { 46 is ($seen{$_}, 1, "Our victim had a $_ OP"); 47} 48is_deeply ([keys %debug], [], 'walkoptree_debug was not called'); 49 50B::walkoptree_debug(2); 51is (B::walkoptree_debug, 1, 'walkoptree_debug() is 1'); 52%seen = (); 53 54B::walkoptree(B::svref_2object($victim)->ROOT, "pie"); 55foreach (qw(substcont split split leavesub)) { 56 is ($seen{$_}, 1, "Our victim had a $_ OP"); 57} 58is_deeply (\%debug, \%seen, 'walkoptree_debug was called correctly'); 59 60my %seen2; 61 62# Now try to exercise the code in walkoptree that decides that it can't re-use 63# the object and reference. 64sub B::OP::fiddle { 65 my $name = $_[0]->name; 66 ++$seen2{$name}; 67 if ($name =~ /^s/) { 68 # Take another reference to the reference 69 push @::junk, \$_[0]; 70 } elsif ($name =~ /^p/) { 71 # Take another reference to the object 72 push @::junk, \${$_[0]}; 73 } elsif ($name =~ /^l/) { 74 undef $_[0]; 75 } elsif ($name =~ /g/) { 76 ${$_[0]} = "Muhahahahaha!"; 77 } elsif ($name =~ /^c/) { 78 bless \$_[0]; 79 } 80} 81 82B::walkoptree(B::svref_2object($victim)->ROOT, "fiddle"); 83is_deeply (\%seen2, \%seen, 'everything still seen'); 84 85done_testing(); 86