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.

6 files changed, 30 insertions, 38 deletions

diff --git a/embed.fnc b/embed.fnc
index 9fed8b4113..14a920542a 100644
--- 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 570ed1291d..eb9b3bfcbc 100644
--- 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 fb214d90b4..f9ec7aa019 100644
--- 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 c8811e4a84..2406508559 100644
--- 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 28f3043094..6ec3646c4d 100644
--- 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 b42929e422..66447e3677 100644
--- 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: