diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 28 | ||||
| -rw-r--r-- | ext/XS-APItest/t/sym-hook.t | 26 | ||||
| -rw-r--r-- | toke.c | 7 |
4 files changed, 58 insertions, 4 deletions
@@ -4022,6 +4022,7 @@ ext/XS-APItest/t/svpv.t More generic SvPVbyte and SvPVutf8 tests ext/XS-APItest/t/svsetsv.t Test behaviour of sv_setsv with/without PERL_CORE ext/XS-APItest/t/swaplabel.t test recursive descent label parsing ext/XS-APItest/t/swaptwostmts.t test recursive descent statement parsing +ext/XS-APItest/t/sym-hook.t Test rv2cv hooks for bareword lookup ext/XS-APItest/t/temp_lv_sub.t XS::APItest: tests for lvalue subs returning temps ext/XS-APItest/t/underscore_length.t Test find_rundefsv() ext/XS-APItest/t/utf16_to_utf8.t Test behaviour of utf16_to_utf8{,reversed} 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___'); @@ -3773,8 +3773,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) return 0; } } - } else - gv = NULL; + } } s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); /* start is the beginning of the possible filehandle/object, @@ -3783,7 +3782,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) */ if (*start == '$') { - if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || + if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || isUPPER(*PL_tokenbuf)) return 0; #ifdef PERL_MAD @@ -3810,7 +3809,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) if (indirgv && GvCVu(indirgv)) return 0; /* filehandle or package name makes it a method */ - if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { + if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { #ifdef PERL_MAD soff = s - SvPVX(PL_linestr); #endif |