diff options
| -rw-r--r-- | opcode.h | 2 | ||||
| -rwxr-xr-x | opcode.pl | 2 | ||||
| -rw-r--r-- | pod/perlsub.pod | 3 | ||||
| -rw-r--r-- | pod/perltodo.pod | 4 | ||||
| -rw-r--r-- | pp.c | 5 | ||||
| -rw-r--r-- | t/op/cproto.t | 2 | ||||
| -rwxr-xr-x | t/op/override.t | 15 | ||||
| -rw-r--r-- | toke.c | 42 |
8 files changed, 61 insertions, 14 deletions
@@ -1562,7 +1562,7 @@ EXTCONST U32 PL_opargs[] = { 0x00002206, /* srefgen */ 0x0001368c, /* ref */ 0x00122804, /* bless */ - 0x00001608, /* backtick */ + 0x00003608, /* backtick */ 0x00012808, /* glob */ 0x0001d608, /* readline */ 0x00000c08, /* rcatline */ @@ -586,7 +586,7 @@ bless bless ck_fun s@ S S? # Pushy I/O. -backtick quoted execution (``, qx) ck_open t% +backtick quoted execution (``, qx) ck_open t% S # glob defaults its first arg to $_ glob glob ck_glob t@ S? readline <HANDLE> ck_null t% F? diff --git a/pod/perlsub.pod b/pod/perlsub.pod index f11f1ae713..5ecd346a14 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -1372,7 +1372,8 @@ And, as you'll have noticed from the previous example, if you override C<glob>, the C<< <*> >> glob operator is overridden as well. In a similar fashion, overriding the C<readline> function also overrides -the equivalent I/O operator C<< <FILEHANDLE> >>. +the equivalent I/O operator C<< <FILEHANDLE> >>. Also, overriding +C<readpipe> also overrides the operators C<``> and C<qx//>. Finally, some built-ins (e.g. C<exists> or C<grep>) can't be overridden. diff --git a/pod/perltodo.pod b/pod/perltodo.pod index bd76a1c719..2f16a22edb 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -528,10 +528,6 @@ its performance to be measured, and its bugs to be easily demonstrated. Allow to delete functions. One can already undef them, but they're still in the stash. -=head2 Make readpipe overridable - -so we can override qx// as well. - =head2 optional optimizer Make the peephole optimizer optional. Currently it performs two tasks as @@ -387,7 +387,7 @@ PP(pp_prototype) SV *ret = &PL_sv_undef; if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { - const char * const s = SvPVX_const(TOPs); + const char * s = SvPVX_const(TOPs); if (strnEQ(s, "CORE::", 6)) { const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1); if (code < 0) { /* Overridable. */ @@ -403,6 +403,9 @@ PP(pp_prototype) ret = sv_2mortal(newSVpvs("_;$")); goto set; } + if (code == -KEY_readpipe) { + s = "CORE::backtick"; + } while (i < MAXO) { /* The slow way. */ if (strEQ(s + 6, PL_op_name[i]) || strEQ(s + 6, PL_op_desc[i])) diff --git a/t/op/cproto.t b/t/op/cproto.t index 1b9cf4af95..89bd555b24 100644 --- a/t/op/cproto.t +++ b/t/op/cproto.t @@ -174,7 +174,7 @@ read (*\$$;$) readdir (*) readline (;*) readlink (_) -readpipe unknown +readpipe ($) recv (*\$$$) redo undef ref (_) diff --git a/t/op/override.t b/t/op/override.t index 9cbd57370b..60d772b6c9 100755 --- a/t/op/override.t +++ b/t/op/override.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 22; +plan tests => 26; # # This file tries to test builtin override using CORE::GLOBAL @@ -80,6 +80,19 @@ BEGIN { *Rgs::readline = sub (;*) { --$r }; } ::is( <$pad_fh> , 11 ); } +# Global readpipe() override +BEGIN { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; } +is( `rm`, "rm 10", '``' ); +is( qx/cp/, "cp 9", 'qx' ); + +# Non-global readpipe() override +BEGIN { *Rgs::readpipe = sub ($) { ++$r . " $_[0]" }; } +{ + package Rgs; + ::is( `rm`, "10 rm", '``' ); + ::is( qx/cp/, "11 cp", 'qx' ); +} + # Verify that the parsing of overriden keywords isn't messed up # by the indirect object notation { @@ -1541,6 +1541,14 @@ S_sublex_start(pTHX) PL_expect = XTERMORDORDOR; return THING; } + else if (op_type == OP_BACKTICK && PL_lex_op) { + /* readpipe() vas overriden */ + cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff); + yylval.opval = PL_lex_op; + PL_lex_op = + PL_lex_stuff = NULL; + return THING; + } PL_sublex_info.super_state = PL_lex_state; PL_sublex_info.sub_inwhat = op_type; @@ -2840,6 +2848,34 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) return gv_stashpv(pkgname, FALSE); } +/* + * S_readpipe_override + * Check whether readpipe() is overriden, and generates the appropriate + * optree, provided sublex_start() is called afterwards. + */ +STATIC void +S_readpipe_override() +{ + GV **gvp; + GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV); + yylval.ival = OP_BACKTICK; + if ((gv_readpipe + && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)) + || + ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE)) + && (gv_readpipe = *gvp) != (GV*)&PL_sv_undef + && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))) + { + PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */ + newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe)))); + } + else { + set_csh(); + } +} + #ifdef PERL_MAD /* * Perl_madlex @@ -4951,8 +4987,7 @@ Perl_yylex(pTHX) no_op("Backticks",s); if (!s) missingterm(NULL); - yylval.ival = OP_BACKTICK; - set_csh(); + S_readpipe_override(); TERM(sublex_start()); case '\\': @@ -6271,8 +6306,7 @@ Perl_yylex(pTHX) s = scan_str(s,!!PL_madskills,FALSE); if (!s) missingterm(NULL); - yylval.ival = OP_BACKTICK; - set_csh(); + S_readpipe_override(); TERM(sublex_start()); case KEY_return: |