add $B::overlay feature

This allows you to alter the read-only "view" of an optree, by making
particular B::*OP methods on particular op nodes return customised values.
Intended to be used by B::Deparse to "undo" optimisations, thus making it
easier to add new optree optimisations without breaking Deparse.

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 97bfd08..6e11611 100644 (file)
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -1235,6 +1235,29 @@ Since perl 5.17.1
 =back
 
 
+=head2 $B::overlay
+
+Although the optree is read-only, there is an overlay facility that allows
+you to override what values the various B::*OP methods return for a
+particular op. C<$B::overlay> should be set to reference a two-deep hash:
+indexed by OP address, then method name. Whenever a an op method is
+called, the value in the hash is returned if it exists. This facility is
+used by B::Deparse to "undo" some optimisations. For example:
+
+
+    local $B::overlay = {};
+    ...
+    if ($op->name eq "foo") {
+        $B::overlay->{$$op} = {
+                name => 'bar',
+                next => $op->next->next,
+        };
+    }
+    ...
+    $op->name # returns "bar"
+    $op->next # returns the next op but one
+
+
 =head1 AUTHOR
 
 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>

diff --git a/ext/B/B.xs b/ext/B/B.xs
index a4386b6..1a6e257 100644 (file)
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -241,6 +241,38 @@ make_op_object(pTHX_ const OP *o)
     return opsv;
 }
 
+
+static SV *
+get_overlay_object(pTHX_ const OP *o, const char * const name, U32 namelen)
+{
+    HE *he;
+    SV **svp;
+    SV *key;
+    SV *sv =get_sv("B::overlay", 0);
+    if (!sv || !SvROK(sv))
+       return NULL;
+    sv = SvRV(sv);
+    if (SvTYPE(sv) != SVt_PVHV)
+       return NULL;
+    key = newSViv(PTR2IV(o));
+    he = hv_fetch_ent((HV*)sv, key, 0, 0);
+    SvREFCNT_dec(key);
+    if (!he)
+       return NULL;
+    sv = HeVAL(he);
+    if (!sv || !SvROK(sv))
+       return NULL;
+    sv = SvRV(sv);
+    if (SvTYPE(sv) != SVt_PVHV)
+       return NULL;
+    svp = hv_fetch((HV*)sv, name, namelen, 0);
+    if (!svp)
+       return NULL;
+    sv = *svp;
+    return sv;
+}
+
+
 static SV *
 make_sv_object(pTHX_ SV *sv)
 {
@@ -967,10 +999,16 @@ next(o)
     PPCODE:
        if (ix < 0 || ix > 46)
            croak("Illegal alias %d for B::*OP::next", (int)ix);
-       offset = op_methods[ix].offset;
+       ret = get_overlay_object(aTHX_ o,
+                           op_methods[ix].name, op_methods[ix].namelen);
+       if (ret) {
+           ST(0) = ret;
+           XSRETURN(1);
+       }
 
        /* handle non-direct field access */
 
+       offset = op_methods[ix].offset;
        if (offset < 0) {
            switch (ix) {
 #ifdef USE_ITHREADS

diff --git a/ext/B/t/b.t b/ext/B/t/b.t
index 6912719..a065375 100644 (file)
--- a/ext/B/t/b.t
+++ b/ext/B/t/b.t
@@ -320,4 +320,60 @@ SKIP: {
        'different COP->stashoff for different stashes';
 }
 
+
+# Test $B::overlay
+{
+    my $methods = {
+       BINOP =>  [ qw(last) ],
+       COP   =>  [ qw(arybase cop_seq file filegv hints hints_hash io
+                      label line stash stashpv
+                      stashoff warnings) ],
+       LISTOP => [ qw(children) ],
+       LOGOP =>  [ qw(other) ],
+       LOOP  =>  [ qw(lastop nextop redoop) ],
+       OP    =>  [ qw(desc flags name next opt ppaddr private sibling
+                      size spare targ type) ],
+       PADOP =>  [ qw(gv padix sv) ],
+       PMOP  =>  [ qw(code_list pmflags pmoffset pmreplroot pmreplstart pmstash pmstashpv precomp reflags) ],
+       PVOP  =>  [ qw(pv) ],
+       SVOP  =>  [ qw(gv sv) ],
+       UNOP  =>  [ qw(first) ],
+    };
+
+    my $overlay = {};
+    my $op = B::svref_2object(sub { my $x = 1 })->ROOT;
+
+    for my $class (sort keys %$methods) {
+       for my $meth (@{$methods->{$class}}) {
+           my $full = "B::${class}::$meth";
+           die "Duplicate method '$full'\n"
+               if grep $_ eq $full, @{$overlay->{$meth}};
+           push @{$overlay->{$meth}}, "B::${class}::$meth";
+       }
+    }
+
+    {
+       local $B::overlay; # suppress 'used once' warning
+       local $B::overlay = { $$op => $overlay };
+
+       for my $class (sort keys %$methods) {
+           bless $op, "B::$class"; # naughty
+           for my $meth (@{$methods->{$class}}) {
+               if ($op->can($meth)) {
+                   my $list = $op->$meth;
+                   ok(defined $list
+                           && ref($list) eq "ARRAY"
+                           && grep($_ eq "B::${class}::$meth", @$list),
+                       "overlay: B::$class $meth");
+               }
+               else {
+                   pass("overlay: B::$class $meth (skipped; no method)");
+               }
+           }
+       }
+    }
+    # B::overlay should be disabled again here
+    is($op->name, "leavesub", "overlay: orig name");
+}
+
 done_testing();