Fix the overriding of CORE::do, just like change 25599

was fixing the overriding of CORE::require

p4raw-id: //depot/perl@25616

diff --git a/embed.fnc b/embed.fnc
index 6c0b1e8..b1959d3 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -221,7 +221,7 @@ p   |I32    |do_trans       |NN SV* sv
 p      |UV     |do_vecget      |NN SV* sv|I32 offset|I32 size
 p      |void   |do_vecset      |NN SV* sv
 p      |void   |do_vop         |I32 optype|NN SV* sv|NN SV* left|NN SV* right
-p      |OP*    |dofile         |NN OP* term
+p      |OP*    |dofile         |NN OP* term|I32 force_builtin
 ApR    |I32    |dowantarray
 Ap     |void   |dump_all
 Ap     |void   |dump_eval

diff --git a/embed.h b/embed.h
index 0cd11e6..154d7e2 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -2211,7 +2211,7 @@
 #define do_vecget(a,b,c)       Perl_do_vecget(aTHX_ a,b,c)
 #define do_vecset(a)           Perl_do_vecset(aTHX_ a)
 #define do_vop(a,b,c,d)                Perl_do_vop(aTHX_ a,b,c,d)
-#define dofile(a)              Perl_dofile(aTHX_ a)
+#define dofile(a,b)            Perl_dofile(aTHX_ a,b)
 #endif
 #define dowantarray()          Perl_dowantarray(aTHX)
 #define dump_all()             Perl_dump_all(aTHX)

diff --git a/op.c b/op.c
index 275e9fd..6500d49 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3187,14 +3187,18 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
 }
 
 OP *
-Perl_dofile(pTHX_ OP *term)
+Perl_dofile(pTHX_ OP *term, I32 force_builtin)
 {
     OP *doop;
-    GV *gv;
+    GV *gv = Nullgv;
 
-    gv = gv_fetchpv("do", FALSE, SVt_PVCV);
-    if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
-       gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
+    if (!force_builtin) {
+       gv = gv_fetchpv("do", FALSE, SVt_PVCV);
+       if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
+           GV **gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
+           if (gvp) gv = *gvp; else gv = Nullgv;
+       }
+    }
 
     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
        doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,

diff --git a/perly.act b/perly.act
index 05269e2..243dfcb 100644 (file)
--- a/perly.act
+++ b/perly.act
@@ -707,7 +707,7 @@ case 2:
 
   case 133:
 #line 569 "perly.y"
-    { (yyval.opval) = dofile((yyvsp[0].opval)); ;}
+    { (yyval.opval) = dofile((yyvsp[0].opval), (yyvsp[-1].ival)); ;}
     break;
 
   case 134:

diff --git a/perly.y b/perly.y
index e88add1..1d20b04 100644 (file)
--- a/perly.y
+++ b/perly.y
@@ -566,7 +566,7 @@ anonymous:  '[' expr ']'
 
 /* Things called with "do" */
 termdo :       DO term %prec UNIOP                     /* do $filename */
-                       { $$ = dofile($2); }
+                       { $$ = dofile($2, $1); }
        |       DO block        %prec '('               /* do { code */
                        { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); }
        |       DO WORD '(' ')'                         /* do somesub() */

diff --git a/proto.h b/proto.h
index 0fbe1df..64fa28a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -445,7 +445,7 @@ PERL_CALLCONV void  Perl_do_vop(pTHX_ I32 optype, SV* sv, SV* left, SV* right)
                        __attribute__nonnull__(pTHX_3)
                        __attribute__nonnull__(pTHX_4);
 
-PERL_CALLCONV OP*      Perl_dofile(pTHX_ OP* term)
+PERL_CALLCONV OP*      Perl_dofile(pTHX_ OP* term, I32 force_builtin)
                        __attribute__nonnull__(pTHX_1);
 
 PERL_CALLCONV I32      Perl_dowantarray(pTHX)

diff --git a/toke.c b/toke.c
index 93623f6..998e7a1 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -4520,9 +4520,9 @@ Perl_yylex(pTHX)
                    Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
                if (tmp < 0)
                    tmp = -tmp;
-               else if (tmp == KEY_require)
+               else if (tmp == KEY_require || tmp == KEY_do)
                    /* that's a way to remember we saw "CORE::" */
-                   orig_keyword = KEY_require;
+                   orig_keyword = tmp;
                goto reserved_word;
            }
            goto just_a_word;
@@ -4606,6 +4606,12 @@ Perl_yylex(pTHX)
                PRETERMBLOCK(DO);
            if (*s != '\'')
                s = force_word(s,WORD,TRUE,TRUE,FALSE);
+           if (orig_keyword == KEY_do) {
+               orig_keyword = 0;
+               yylval.ival = 1;
+           }
+           else
+               yylval.ival = 0;
            OPERATOR(DO);
 
        case KEY_die: