diff options
Diffstat (limited to 'ext')
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 28 | ||||
| -rw-r--r-- | ext/XS-APItest/t/sym-hook.t | 26 |
2 files changed, 54 insertions, 0 deletions
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 57c8fd078d..3785c3b059 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1101,6 +1101,29 @@ addissub_myck_add(pTHX_ OP *op) return newBINOP(OP_SUBTRACT, flags, aop, bop); } +static Perl_check_t old_ck_rv2cv; + +static OP * +my_ck_rv2cv(pTHX_ OP *o) +{ + SV *ref; + SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addunder", 0); + OP *aop; + + if (flag_svp && SvTRUE(*flag_svp) && (o->op_flags & OPf_KIDS) + && (aop = cUNOPx(o)->op_first) && aop->op_type == OP_CONST + && aop->op_private & (OPpCONST_ENTERED|OPpCONST_BARE) + && (ref = cSVOPx(aop)->op_sv) && SvPOK(ref) && SvCUR(ref) + && *(SvEND(ref)-1) == 'o') + { + SvGROW(ref, SvCUR(ref)+2); + *SvEND(ref) = '_'; + SvCUR(ref)++; + *SvEND(ref) = '\0'; + } + return old_ck_rv2cv(aTHX_ o); +} + #include "const-c.inc" MODULE = XS::APItest PACKAGE = XS::APItest @@ -3349,6 +3372,11 @@ setup_addissub() CODE: wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add); +void +setup_rv2cv_addunderbar() +CODE: + wrap_op_checker(OP_RV2CV, my_ck_rv2cv, &old_ck_rv2cv); + #ifdef USE_ITHREADS bool diff --git a/ext/XS-APItest/t/sym-hook.t b/ext/XS-APItest/t/sym-hook.t new file mode 100644 index 0000000000..023aad9b4d --- /dev/null +++ b/ext/XS-APItest/t/sym-hook.t @@ -0,0 +1,26 @@ + +# Test that PL_check hooks for RV2*V can override symbol lookups. + +# So far we only test RV2CV. + +use XS::APItest; +use Test::More tests => 3; + +BEGIN { + setup_rv2cv_addunderbar; + $^H{'XS::APItest/addunder'} = 1; # make foo() actually call foo_() +} + +sub foo_ { @_ ? shift . "___" : "phew" } + +is(foo(), "phew"); + +# Make sure subs looked up via rv2cv check hooks are not treated as second- +# class subs. + +BEGIN { # If there is a foo symbol, this test will not be testing anything. + delete $::{foo}; +} +is((foo bar), 'bar___'); +$bar = "baz"; +is((foo $bar), 'baz___'); |