Some tests for B::walkoptree.

Quite likely coverage isn't that good, but some tests are better than none.
More tests welcome.

1 files changed, 60 insertions, 0 deletions

diff --git a/ext/B/t/walkoptree.t b/ext/B/t/walkoptree.t
new file mode 100644
index 0000000000..9757f88071
--- /dev/null
+++ b/ext/B/t/walkoptree.t
@@ -0,0 +1,60 @@
+#!./perl
+
+BEGIN {
+    unshift @INC, 't';
+    require Config;
+    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+        print "1..0 # Skip -- Perl configured without B module\n";
+        exit 0;
+    }
+}
+
+use warnings;
+use strict;
+use Test::More;
+
+BEGIN { use_ok( 'B' ); }
+
+# Somewhat minimal tests.
+
+my %seen;
+
+sub B::OP::pie {
+    my $self = shift;
+    return ++$seen{$self->name};
+}
+
+my %debug;
+sub B::OP::walkoptree_debug {
+    my $self = shift;
+    return ++$debug{$self->name};
+}
+
+my $victim = sub {
+    # This gives us a substcont, which gets to the second recursive call
+    # point (in the if statement in the XS code)
+    $_[0] =~ s/(a)/$1/;
+    # PMOP_pmreplroot(cPMOPo) is NULL for this
+    $_[0] =~ s/(b)//;
+    # This gives an OP_PUSHRE
+    split /c/;
+};
+
+is (B::walkoptree_debug, 0, 'walkoptree_debug() is 0');
+B::walkoptree(B::svref_2object($victim)->ROOT, "pie");
+foreach (qw(substcont pushre split leavesub)) {
+    is ($seen{$_}, 1, "Our victim had a $_ OP");
+}
+is_deeply ([keys %debug], [], 'walkoptree_debug was not called');
+
+B::walkoptree_debug(2);
+is (B::walkoptree_debug, 1, 'walkoptree_debug() is 1');
+%seen = ();
+
+B::walkoptree(B::svref_2object($victim)->ROOT, "pie");
+foreach (qw(substcont pushre split leavesub)) {
+    is ($seen{$_}, 1, "Our victim had a $_ OP");
+}
+is_deeply (\%debug, \%seen, 'walkoptree_debug was called correctly');
+
+done_testing();