Fix qx, `` and <<`` overrides

This resolves two RT tickets:
• #115330 is that qx and `` overrides do not support interpolation.
• #119827 is that <<`` does not support readpipe overrides at all.

The obvious fix for #115330 fixes #119827 at the same time.

When quote-like operators are parsed, after the string has been
scanned S_sublex_push is called, which decides which of two paths
to follow:
1) For things not requiring interpolation, the string is passed to
   tokeq (originally called q, it handles double backslashes and back-
   slashed delimiters) and returned to the parser immediately.
2) For anything that interpolates, the lexer enters a special inter-
   polation mode (LEX_INTERPPUSH) and goes through a more complex
   sequence over the next few calls (e.g., qq"a.$b.c" is turned into
  ‘stringify ( "a." . $ b . ".c" )’).

When commit e3f73d4ed (Oct 2006, perl 5.10) added support for overrid-
ing `` and qx with a readpipe sub, it did so by creating an entersub
op in toke.c and making S_sublex_push follow path no. 1, taking the
result if tokeq and inserting it into the already-constructed op tree
for the sub call.

That approach caused interpolation to be skipped when qx or `` is
overridden.  Furthermore it didn’t touch <<`` at all.

The easiest solution is to let toke.c follow its normal path and
create a backtick op (instead of trying to half-intercept it), and
to deal with override lookup afterwards in ck_backtick, the same way
require overrides are handled.  Since <<`` also turns into a backtick
op, it gets handled too that way.

diff --git a/embed.fnc b/embed.fnc
index 9fed8b4..14a9205 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2258,7 +2258,6 @@ s |char*  |force_strict_version   |NN char *s
 s      |char*  |force_word     |NN char *start|int token|int check_keyword \
                                |int allow_pack
 s      |SV*    |tokeq          |NN SV *sv
-s      |void   |readpipe_override|
 sR     |char*  |scan_const     |NN char *start
 iR     |SV*    |get_and_check_backslash_N_name|NN const char* s \
                                |NN const char* const e

diff --git a/embed.h b/embed.h
index 570ed12..eb9b3bf 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1643,7 +1643,6 @@
 #define no_op(a,b)             S_no_op(aTHX_ a,b)
 #define parse_ident(a,b,c,d,e) S_parse_ident(aTHX_ a,b,c,d,e)
 #define pending_ident()                S_pending_ident(aTHX)
-#define readpipe_override()    S_readpipe_override(aTHX)
 #define scan_const(a)          S_scan_const(aTHX_ a)
 #define scan_formline(a)       S_scan_formline(aTHX_ a)
 #define scan_heredoc(a)                S_scan_heredoc(aTHX_ a)

diff --git a/op.c b/op.c
index fb214d9..f9ec7aa 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8442,10 +8442,22 @@ S_io_hints(pTHX_ OP *o)
 OP *
 Perl_ck_backtick(pTHX_ OP *o)
 {
+    GV *gv;
+    OP *newop = NULL;
     PERL_ARGS_ASSERT_CK_BACKTICK;
-    S_io_hints(aTHX_ o);
-    if (!(o->op_flags & OPf_KIDS)) {
-       OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
+    /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
+    if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling
+     && (gv = gv_override("readpipe",8))) {
+       newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
+                       op_append_elem(OP_LIST,
+                                      cUNOPo->op_first->op_sibling,
+                                      newCVREF(0, newGVOP(OP_GV, 0, gv))
+                                     ));
+       cUNOPo->op_first->op_sibling = NULL;
+    }
+    else if (!(o->op_flags & OPf_KIDS))
+       newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
+    if (newop) {
 #ifdef PERL_MAD
        op_getmad(o,newop,'O');
 #else
@@ -8453,6 +8465,7 @@ Perl_ck_backtick(pTHX_ OP *o)
 #endif
        return newop;
     }
+    S_io_hints(aTHX_ o);
     return o;
 }
 

diff --git a/proto.h b/proto.h
index c8811e4..2406508 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -7469,7 +7469,6 @@ STATIC void       S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_pa
        assert(s); assert(d); assert(e)
 
 STATIC int     S_pending_ident(pTHX);
-STATIC void    S_readpipe_override(pTHX);
 STATIC char*   S_scan_const(pTHX_ char *start)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);

diff --git a/t/op/exec.t b/t/op/exec.t
index 28f3043..6ec3646 100644 (file)
--- a/t/op/exec.t
+++ b/t/op/exec.t
@@ -36,7 +36,7 @@ $ENV{LANGUAGE} = 'C';         # Ditto in GNU.
 my $Is_VMS   = $^O eq 'VMS';
 my $Is_Win32 = $^O eq 'MSWin32';
 
-plan(tests => 22);
+plan(tests => 24);
 
 my $Perl = which_perl();
 
@@ -129,6 +129,17 @@ END
     is( readpipe, "ok\n", 'readpipe default argument' );
 }
 
+package o {
+    use subs "readpipe";
+    sub readpipe { pop }
+    ::is `${\"hello"}`, 'hello',
+         'overridden `` interpolates [perl #115330]';
+    ::is <<`119827`, "ls\n",
+l${\"s"}
+119827
+        '<<`` respects overrides and interpolates [perl #119827]';
+}
+
 TODO: {
     my $tnum = curr_test();
     if( $^O =~ /Win32/ ) {

diff --git a/toke.c b/toke.c
index b42929e..66447e3 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2606,14 +2606,6 @@ S_sublex_start(pTHX)
            PL_expect = XTERMORDORDOR;
        return THING;
     }
-    else if (op_type == OP_BACKTICK && PL_lex_op) {
-       /* readpipe() was overridden */
-       cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
-       pl_yylval.opval = PL_lex_op;
-       PL_lex_op = NULL;
-       PL_lex_stuff = NULL;
-       return THING;
-    }
 
     PL_sublex_info.super_state = PL_lex_state;
     PL_sublex_info.sub_inwhat = (U16)op_type;
@@ -4472,27 +4464,6 @@ S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
     return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
 }
 
-/*
- * S_readpipe_override
- * Check whether readpipe() is overridden, and generates the appropriate
- * optree, provided sublex_start() is called afterwards.
- */
-STATIC void
-S_readpipe_override(pTHX)
-{
-    GV **gvp;
-    GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
-    pl_yylval.ival = OP_BACKTICK;
-    if ((gv_readpipe = gv_override("readpipe",8)))
-    {
-       COPLINE_SET_FROM_MULTI_END;
-       PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
-           op_append_elem(OP_LIST,
-               newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
-               newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
-    }
-}
-
 #ifdef PERL_MAD 
  /*
  * Perl_madlex
@@ -6933,7 +6904,7 @@ Perl_yylex(pTHX)
            no_op("Backticks",s);
        if (!s)
            missingterm(NULL);
-       readpipe_override();
+       pl_yylval.ival = OP_BACKTICK;
        TERM(sublex_start());
 
     case '\\':
@@ -8489,7 +8460,7 @@ Perl_yylex(pTHX)
            s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
            if (!s)
                missingterm(NULL);
-           readpipe_override();
+           pl_yylval.ival = OP_BACKTICK;
            TERM(sublex_start());
 
        case KEY_return: