Commit | Line | Data |
---|---|---|
ffc7a570 NC |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
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 | ||
12 | use warnings; | |
13 | use strict; | |
14 | use Test::More; | |
15 | ||
16 | BEGIN { use_ok( 'B' ); } | |
17 | ||
18 | # Somewhat minimal tests. | |
19 | ||
20 | my %seen; | |
21 | ||
22 | sub B::OP::pie { | |
23 | my $self = shift; | |
24 | return ++$seen{$self->name}; | |
25 | } | |
26 | ||
27 | my %debug; | |
28 | sub B::OP::walkoptree_debug { | |
29 | my $self = shift; | |
30 | return ++$debug{$self->name}; | |
31 | } | |
32 | ||
33 | my $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) | |
bb933b9b | 36 | $_[0] =~ s/(a)/ $1/; |
ffc7a570 NC |
37 | # PMOP_pmreplroot(cPMOPo) is NULL for this |
38 | $_[0] =~ s/(b)//; | |
5012eebe | 39 | # This gives an OP_SPLIT |
ffc7a570 NC |
40 | split /c/; |
41 | }; | |
42 | ||
43 | is (B::walkoptree_debug, 0, 'walkoptree_debug() is 0'); | |
44 | B::walkoptree(B::svref_2object($victim)->ROOT, "pie"); | |
5012eebe | 45 | foreach (qw(substcont split split leavesub)) { |
ffc7a570 NC |
46 | is ($seen{$_}, 1, "Our victim had a $_ OP"); |
47 | } | |
48 | is_deeply ([keys %debug], [], 'walkoptree_debug was not called'); | |
49 | ||
50 | B::walkoptree_debug(2); | |
51 | is (B::walkoptree_debug, 1, 'walkoptree_debug() is 1'); | |
52 | %seen = (); | |
53 | ||
54 | B::walkoptree(B::svref_2object($victim)->ROOT, "pie"); | |
5012eebe | 55 | foreach (qw(substcont split split leavesub)) { |
ffc7a570 NC |
56 | is ($seen{$_}, 1, "Our victim had a $_ OP"); |
57 | } | |
58 | is_deeply (\%debug, \%seen, 'walkoptree_debug was called correctly'); | |
59 | ||
20f7624e NC |
60 | my %seen2; |
61 | ||
62 | # Now try to exercise the code in walkoptree that decides that it can't re-use | |
63 | # the object and reference. | |
64 | sub 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 | ||
82 | B::walkoptree(B::svref_2object($victim)->ROOT, "fiddle"); | |
83 | is_deeply (\%seen2, \%seen, 'everything still seen'); | |
84 | ||
ffc7a570 | 85 | done_testing(); |