Make readpipe() overridable (and also `` and qx//)

p4raw-id: //depot/perl@29168

8 files changed, 61 insertions, 14 deletions

diff --git a/opcode.h b/opcode.h
index 4b32c85f31..c62943b57d 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 7098f131e4..7857c09651 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	<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
diff --git a/pp.c b/pp.c
index beee803b66..229f703417 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 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
 {
diff --git a/toke.c b/toke.c
index e3efd8fb32..40b5465066 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: