From: Rafael Garcia-Suarez Date: Tue, 31 Oct 2006 13:34:30 +0000 (+0000) Subject: Make readpipe() overridable (and also `` and qx//) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e3f73d4edc1b72464d0a94ac202f6e1bd3daf149;p=p5sagit%2Fp5-mst-13.2.git Make readpipe() overridable (and also `` and qx//) p4raw-id: //depot/perl@29168 --- diff --git a/opcode.h b/opcode.h index 4b32c85..c62943b 100644 --- a/opcode.h +++ b/opcode.h @@ -1562,7 +1562,7 @@ EXTCONST U32 PL_opargs[] = { 0x00002206, /* srefgen */ 0x0001368c, /* ref */ 0x00122804, /* bless */ - 0x00001608, /* backtick */ + 0x00003608, /* backtick */ 0x00012808, /* glob */ 0x0001d608, /* readline */ 0x00000c08, /* rcatline */ diff --git a/opcode.pl b/opcode.pl index 7098f13..7857c09 100755 --- a/opcode.pl +++ b/opcode.pl @@ -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 ck_null t% F? diff --git a/pod/perlsub.pod b/pod/perlsub.pod index f11f1ae..5ecd346 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, the C<< <*> >> glob operator is overridden as well. In a similar fashion, overriding the C function also overrides -the equivalent I/O operator C<< >>. +the equivalent I/O operator C<< >>. Also, overriding +C also overrides the operators C<``> and C. Finally, some built-ins (e.g. C or C) can't be overridden. diff --git a/pod/perltodo.pod b/pod/perltodo.pod index bd76a1c..2f16a22 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 diff --git a/pp.c b/pp.c index beee803..229f703 100644 --- a/pp.c +++ b/pp.c @@ -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 1b9cf4a..89bd555 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 9cbd573..60d772b 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 { diff --git a/toke.c b/toke.c index e3efd8f..40b5465 100644 --- a/toke.c +++ b/toke.c @@ -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: