Some tests for B::walkoptree.

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

diff --git a/MANIFEST b/MANIFEST
index a6a0939..a6530cc 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3118,6 +3118,7 @@ ext/B/t/o.t               See if O works
 ext/B/t/pragma.t       See if user pragmas work.
 ext/B/t/showlex.t      See if B::ShowLex works
 ext/B/t/terse.t                See if B::Terse works
+ext/B/t/walkoptree.t   See if B::walkoptree (and friends) work
 ext/B/t/xref.t         See if B::Xref works
 ext/B/typemap                  Compiler backend interface types
 ext/Devel-DProf/Changes                Perl code profiler changelog

diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 3cd17ed..3f304e1 100755 (executable)
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -1645,6 +1645,7 @@ use File::Glob qw(:case);
                                ext/B/t/xref.t
                                ext/B/t/f_map.t
                                ext/B/t/optree_misc.t
+                               ext/B/t/walkoptree.t
                                ext/B/hints/openbsd.pl
                                ext/B/hints/darwin.pl
 

diff --git a/ext/B/t/walkoptree.t b/ext/B/t/walkoptree.t
new file mode 100644 (file)
index 0000000..9757f88
--- /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();