This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
rv2cv hooks should not create 2nd-class subs
authorFather Chrysostomos <sprout@cpan.org>
Fri, 6 Jul 2012 21:19:21 +0000 (14:19 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 7 Jul 2012 05:26:32 +0000 (22:26 -0700)
$ perl5.17.2 -Mblib -e 'sub foo{}; foo $bar; use Lexical::Sub baz => sub{}; baz $bar'
Can't call method "baz" on an undefined value at -e line 1.
$ perl5.17.2 -Mblib -e 'sub foo{}; foo bar; use Lexical::Sub baz => sub{}; baz bar'
Can't locate object method "baz" via package "bar" (perhaps you forgot to load "bar"?) at -e line 1.

So if you use Lexical::Sub, your sub doesn’t get to participate in
determining whether ‘foo $bar’ or ‘foo bar’ is a method call.

This is because Lexical::Sub uses an rv2cv hook to intercept sub
lookup.  And toke.c:S_intuit_method thinks there cannot be a CV with-
out a GV (which was the case when it was first written).

Commit f7461760 introduced this rv2cv hooking for bareword lookup, but
failed to update S_intuit_method accordingly.

MANIFEST
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/sym-hook.t [new file with mode: 0644]
toke.c

index c34be02..7a5d0c0 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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}
index 57c8fd0..3785c3b 100644 (file)
@@ -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 (file)
index 0000000..023aad9
--- /dev/null
@@ -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___');
diff --git a/toke.c b/toke.c
index 44a65aa..439ce15 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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