From: Lubomir Rintel (GoodData) <lubo.rintel@gooddata.com>
Date: Thu, 22 Apr 2010 16:19:23 +0000 (+0200)
Subject: Globs that are in symbol table can be un-globbed
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b9e00b79e4947c49d5520633f9efd2a8e39ec14f;p=p5sagit%2Fp5-mst-13.2.git

Globs that are in symbol table can be un-globbed

If a symbol table entry is undefined when a glob is assigned into it, it
gets a FAKE flag which makes it possible to be downgraded when non-glob
is subsequently assigned into it. It doesn't really matter, until we
decide to localize it -- it wouldn't be possible to restore its GP upon
context return if it changed type, therefore we must not do that.

This patch turns off FAKE flag when localizing a GV and restores it when
the context is left. A test case is included.
---

diff --git a/scope.c b/scope.c
index 6ee1254..6493933 100644
--- a/scope.c
+++ b/scope.c
@@ -281,7 +281,15 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty)
 
     PERL_ARGS_ASSERT_SAVE_GP;
 
-    save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
+    SSCHECK(4);
+    SSPUSHINT(SvFAKE(gv));
+    SSPUSHPTR(GvGP(gv));
+    SSPUSHPTR(SvREFCNT_inc(gv));
+    SSPUSHINT(SAVEt_GP);
+
+    /* Don't let the localized GV coerce into non-glob, otherwise we would
+     * not be able to restore GP upon leave from context if that happened */
+    SvFAKE_off(gv);
 
     if (empty) {
 	GP *gp = Perl_newGP(aTHX_ gv);
@@ -812,10 +820,11 @@ Perl_leave_scope(pTHX_ I32 base)
 	    *(AV**)ptr = MUTABLE_AV(SSPOPPTR);
 	    break;
 	case SAVEt_GP:				/* scalar reference */
-	    ptr = SSPOPPTR;
 	    gv = MUTABLE_GV(SSPOPPTR);
 	    gp_free(gv);
-	    GvGP(gv) = (GP*)ptr;
+	    GvGP(gv) = (GP*)SSPOPPTR;
+	    if (SSPOPINT)
+		SvFAKE_on(gv);
             /* putting a method back into circulation ("local")*/
 	    if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvNAME_get(hv))
                 mro_method_changed_in(hv);
diff --git a/sv.c b/sv.c
index bc2450d..8179937 100644
--- a/sv.c
+++ b/sv.c
@@ -11581,12 +11581,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
 	    TOPPTR(nss,ix) = pv_dup(c);
 	    break;
 	case SAVEt_GP:				/* scalar reference */
+	    gv = (const GV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = gv_dup_inc(gv, param);
 	    gp = (GP*)POPPTR(ss,ix);
 	    TOPPTR(nss,ix) = gp = gp_dup(gp, param);
 	    (void)GpREFCNT_inc(gp);
-	    gv = (const GV *)POPPTR(ss,ix);
-	    TOPPTR(nss,ix) = gv_dup_inc(gv, param);
-            break;
+	    TOPINT(nss,ix) = POPINT(ss,ix);
+	    break;
 	case SAVEt_FREEOP:
 	    ptr = POPPTR(ss,ix);
 	    if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
diff --git a/t/op/gv.t b/t/op/gv.t
index 382e3f0..f3511e3 100644
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 use warnings;
 
 require './test.pl';
-plan( tests => 188 );
+plan( tests => 191 );
 
 # type coersion on assignment
 $foo = 'foo';
@@ -614,6 +614,15 @@ ok(exists($RT72740a::{s4}), "RT72740a::s4 exists");
 is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly");
 is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly");
 
+# [perl #71686] Globs that are in symbol table can be un-globbed
+$sym = undef;
+$::{fake} = *sym;
+is (eval 'local *::fake = \"chuck"; $fake', 'chuck',
+	"Localized glob didn't coerce into a RV");
+is ($@, '', "Can localize FAKE glob that's present in stash");
+is (scalar $::{fake}, "*main::sym",
+	"Localized FAKE glob's value was correctly restored");
+
 __END__
 Perl
 Rules