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

p4raw-id: //depot/perl@29168

diff --git a/opcode.h b/opcode.h
index 4b32c85..c62943b 100644 (file)
--- 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 (executable)
--- 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 f11f1ae..5ecd346 100644 (file)
--- 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 bd76a1c..2f16a22 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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 (file)
--- 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: