From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Tue, 27 Sep 2005 10:09:46 +0000 (+0000)
Subject: Fix the overriding of CORE::do, just like change 25599
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=850e851687c46990a59eb0bed2e5e3dc49703472;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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: