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.
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
#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)
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
#endif
return newop;
}
+ S_io_hints(aTHX_ o);
return o;
}
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);
my $Is_VMS = $^O eq 'VMS';
my $Is_Win32 = $^O eq 'MSWin32';
-plan(tests => 22);
+plan(tests => 24);
my $Perl = which_perl();
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/ ) {
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;
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
no_op("Backticks",s);
if (!s)
missingterm(NULL);
- readpipe_override();
+ pl_yylval.ival = OP_BACKTICK;
TERM(sublex_start());
case '\\':
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: